Farklı ÇOĞALTARAK, HIZLI Listeleme

[Ömer BARAN]

Merhaba.

Örnek belgemde açıklama yazdım.

A SAYFASINDAKİ her bir satır için,
I süturundaki veri B SAYFASInda bulunacak,
B sayfasındaki bu koşula uyan satırların sayısı kadar satır oluşturulup,
BRN sayfasında listelenecek. GRİ zeminli alan önemli değil.

Örnek; I sütunundaki değer : NCJ90J9C7AC000029 bu değer B SAYFASINDA A sütununda aranacak,
sonuç: başlangıç satırı : 24, bitiş satırı 60 yani 37 satırlık bir sonuç var.
A SAYFASIndaki NCJ90J9C7AC000029 verisinin her bir satırı için,
B sayfasındaki 37 satırlık veri alt alta BRN sayfası C sütununa yazılacak,
BRN sayfası A sütununa, A SAYFASINDAKİ I sütunu ilgili veri, B sütununa da J sütunundaki veri yazılacak.

A SAYFASInın orijinali 5000 satır, B SAYFASInın satır sayısı 60.000 satır kadar.
Hesaplamama göre gerçek belgemde BRN sayfasında oluşacak satır sayısı excel versiyonuma
göre son satır olan 1.048.576 satırdan az ama, artma ihtimaline göre, BRN2 gibi sayfa oluşturulabilir.

For ...Next döngüsü ile işlem biraz fazla süre alıyor.
Hızlandırmak için yöntem arıyorum.

İlgilenecek ustalara teşekkürler.
.

 

[Ömer BARAN]

Mevcut belgemdeki kodlar yerine aşağıdaki kodlar ile işlem süresi 30 saniyenin altına düşüyor,
daha hızlı sonuca gitmek mümkün müdür?
.

[FONT="Arial Narrow"]Sub ÇOĞALTARAK_LİSTELE()
Set Sip = Sheets("A SAYFASI"): Set Var = Sheets("B SAYFASI"): Set Brn = Sheets("BRN")
If Brn.[A1048576].End(3).Row > 1 Then Brn.Range("A2:C1048576").ClearContents
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Zaman = Timer: Brn.Activate
    For sipsat = 2 To Sip.[I1048576].End(3).Row
        topsat = WorksheetFunction.CountIf(Sip.Range("I:I"), Sip.Cells(sipsat, "I"))
        ilk = WorksheetFunction.Match(Sip.Cells(sipsat, "I"), Var.Range("A:A"), 0)
        son = ilk + WorksheetFunction.CountIf(Var.Range("A:A"), Sip.Cells(sipsat, "I")) - 1
        adet = topsat * (son - ilk + 1)
            baş = Brn.[A1048576].End(3).Row + 1
            Var.Range("F" & ilk & ":F" & son).Copy
            Brn.Range(Brn.Cells(baş, 3), Brn.Cells(baş + adet - 1, 3)).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
            Sip.Range("I" & sipsat & ":J" & sipsat).Copy
            Brn.Range(Brn.Cells(baş, 1), Brn.Cells(baş + adet - 1, 2)).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
            sipsat = sipsat + topsat - 1
        Next
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Brn.[A2].Select: MsgBox "İşlem, " & Format(Timer - Zaman, "0.00") & " saniyede tamamlandı." & vbLf & _
Format([Brn].[A1048576].End(3).Row - 1, "#,##0") & " satırlık liste oluşturuldu.", vbInformation, "BARAN"
End Sub[/FONT]