Makro Döngü Hızlandırma / Kod Alternatifi

[sametdibek]

Merhaba,

Ekte yazmış olduğum kod kısa bir liste için çalışıyor olmasına rağmen çok uzun sürüyor, aynı işin alternatif bir döngü ile yapılması mümkün müdür acaba?



Dim adr As String
Set sh = Sheets("Data2")
Set musteri = Sheets("Musterilist")
sat1 = Sheets("Data2").Range("B" & Rows.Count).End(xlUp).Row
sat2 = 2

musteri.Range("A2:M2000").ClearContents
Set k = sh.Range("K1:K" & sat1).Find("var", , xlValues, xlWhole)
adr = k.Address

If Not k Is Nothing Then

adr = k.Address
Do
musteri.Cells(sat2, "A").Value = sat2 - 1
musteri.Range("B" & sat2 & ":G" & sat2).Value = sh.Range("E" & k.Row & ":J" & k.Row).Value


sat2 = sat2 + 1
Set k = sh.Range("K2:K" & sat1).FindNext(k)
Loop While Not k Is Nothing And adr <> k.Address

End If

 

[Emir Hüseyin Çoban]

. . .

Sub kod()
    Application.ScreenUpdating = False
    Set sh = Sheets("Data2")
    Set musteri = Sheets("Musterilist")
    sat1 = Sheets("Data2").Cells(Rows.Count, "B").End(3).Row
    sat2 = 2
    musteri.Range("A2:M2000").ClearContents
    
    For i = 1 To sat1
        If UCase(sh.Cells(i, "K")) = "VAR" Then
            musteri.Cells(sat2, "A").Value = sat2 - 1
            musteri.Cells(sat2, "B") = sh.Cells(i, "E")
            musteri.Cells(sat2, "C") = sh.Cells(i, "F")
            musteri.Cells(sat2, "D") = sh.Cells(i, "G")
            musteri.Cells(sat2, "E") = sh.Cells(i, "H")
            musteri.Cells(sat2, "F") = sh.Cells(i, "I")
            musteri.Cells(sat2, "G") = sh.Cells(i, "J")
            sat2 = sat2 + 1
        End If
    Next i

    Application.ScreenUpdating = True
    MsgBox "B i t t i "
End Sub

. . .

 

[sametdibek]

Üstad çok teşekkür ediyorum ama bir önceki koda göre %30 daha fazla uzun sürdüğünü söylemeliyim.
Neden olduğu konusunda ise bir fikrim yok, daha kompleks işlemleri daha kısa zamanda yapabiliyor. Farklı sayfalar arasında veri alış verişi yaptığı için mi bilemiyorum.

yine de emeğiniz ve ilginiz için çok teşekkürler.

selamlar.

 

[Emir Hüseyin Çoban]

Tablonuzu görmek gerekir.
Ado ilede deneye biliriz.

.

 

[Korhan Ayhan]

Merhaba,

Dosyanızın boyutu büyükse kodlar yavaş çalışabilir. Kodları hızlandırmak için genellikle aşağıdaki yapı kullanılır.

Sizin kullandığınız kodlar döngüye göre daha hızlı sonuç verir. Alternatif çözümler üretilebilir. Filtre yöntemi ile veriler aktarılabilir. ADO kullanılabilir. Dictionary nesnesi kullanılabilir. Bunlar içinde dosyanızın küçük bir örneğini eklemeniz gerekir.

Option Explicit

Sub MAKRO()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Sat1 As Long, Sat2 As Long
    Dim Bul As Range, Adres As String, Zaman As Double
    
    Zaman = Timer
    
[COLOR=Red]    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
[/COLOR]    
    Set S1 = Sheets("Data2")
    Set S2 = Sheets("Musterilist")
    Sat1 = S1.Range("B" & S1.Rows.Count).End(xlUp).Row
    Sat2 = 2
    
    S2.Range("A2:M2000").ClearContents
    
    Set Bul = S1.Range("K1:K" & Sat1).Find("var", , xlValues, xlWhole)
    
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            S2.Cells(Sat2, "A").Value = Sat2 - 1
            S2.Range("B" & Sat2 & ":G" & Sat2).Value = S1.Range("E" & Bul.Row & ":J" & Bul.Row).Value
            Sat2 = Sat2 + 1
            Set Bul = S1.Range("K2:K" & Sat1).FindNext(Bul)
        Loop While Not Bul Is Nothing And Adres <> Bul.Address
    End If

[COLOR=Red]    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
[/COLOR]    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye"
End Sub