Soru Makro Hızlandırma

[tuvons]

Arkadaşlar merhaba,

500bin satırlı bi dosyada aşağıdaki kodlarla değişiklik yapıyorum ama çok uzun sürüyor. Bunu hızlandırmanın bir yolu var mıdır?

Sub deneme1()

Set S1 = ActiveWorkbook.Worksheets("TABLO")
sonsatir1001 = S1.Cells(Rows.Count, "A").End(xlUp).Row
Dim subeler As Variant
subeler = Array(80952, 80950, 80701, 80700, 80501, 80500, 80450, 80201, 80200, 80120, 80119, 80117, 80116, 80112, 80111, 80110, 80109, 80108, 80107, 80106, 80104, 80103, 80102, 80101, 80100)
Dim sube As Variant
Dim muhasebeler As Variant
muhasebeler = Range("H2:H108").Value
Dim muhasebe As Variant

Zaman = Timer
Application.ScreenUpdating = False

başlangıç = 2
For Each muhasebe In muhasebeler
    For Each sube In subeler
    
        For x = başlangıç To sonsatir1001
        yuvarlanmıştutar = WorksheetFunction.SumIfs(Range("F2:F" & sonsatir1001), Range("A2:A" & sonsatir1001), sube, Range("G2:G" & sonsatir1001), muhasebe)
        yuvarlanmamıştutar = WorksheetFunction.Round(WorksheetFunction.SumIfs(Range("C2:C" & sonsatir1001), Range("A2:A" & sonsatir1001), sube, Range("G2:G" & sonsatir1001), muhasebe) / 1000, 0)
    
        If yuvarlanmıştutar = yuvarlanmamıştutar Then GoTo bitis2
        If Cells(x, 1) <> sube And Cells(x, 7) <> muhasebe Then GoTo bitis
        If yuvarlanmıştutar > yuvarlanmamıştutar Then GoTo düşür
        If yuvarlanmıştutar < yuvarlanmamıştutar Then GoTo arttır
düşür:
    If Cells(x, 6) = 0 Then GoTo bitis
    Cells(x, 6) = Cells(x, 6) - 1
    GoTo bitis
arttır:
    Cells(x, 6) = Cells(x, 6) + 1
    GoTo bitis
bitis:
        Next x
bitis2:
    Next sube
Next muhasebe

Application.ScreenUpdating = True
        
MsgBox "Özet tablo hazırlanmıştır." & vbLf & vbLf & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
              
End Sub

 

[Muzaffer Ali]

Merhaba.

Eklediğiniz kodlarla ne yapmak istiyorsunuz?
Örnek dosyanızı da eklerseniz çözüm bulmaya çalışalım.

 

[tuvons]

@Muzaffer Ali Bey merhaba,

Dosya ekleme şansım yok maalesef. Yapmak istediğim belirli satırlarda kriterlere uymayanları hücreleri +1 veya -1 koyarak değiştirmek ama bunu yaparken her muhasebede for döngüsü baştan başlayıp 500bininci satıra kadar gidebildiği için makronun çalışması uzun zaman alıyor.

Aşağıdakileri buldum ama henüz deneyemedim. İşe yarar mı sizce?

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False

‘Place your macro code here

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True

 

[Muzaffer Ali]

Örnek dosya(dosyanın kendisi olması şart değil) hazırlayıp eklemiyorsanız ben çözüm üretemem.
Kolay gelsin.

 

[Korhan Ayhan]

Klasik döngülerle sonuca gitmeniz çok zaman alacaktır. Zaten sizde bundan şikayetçi olmuşsunuz.

Bu tarz dosyalar için Array (Dizi) yöntemini kullanmanızı tavsiye ederim. Alternatif olarak eğer tablonuz ADO sorgulamaları için uygunsa bu da düşünülebilir.

Forumda daha önce benzer kodlar bolca paylaşıldı. Arama yaparak kendinize uyarlamayı deneyebilirsiniz.

 

[tuvons]

Teşekkürler @Korhan Ayhan