Soru For Döngüsü Hızlandırma

[tuvons]

Arkadaşlar merhaba,

For döngüsünde TARIH sütunundaki değerlerden içinde bulunduğumuz yıldan önceki yıl olan satırları silmek istiyorum. 300bin satır veride çalışması çok uzun sürüyor. Bunu kısaltma şansımız olabilir mi?

    Application.ScreenUpdating = False

    Set s1 = Worksheets("RAPOR")
    
    starih = WorksheetFunction.Match("TARIH", s1.Range("A1:CC1"), 0)
    
    satirsayisi = s1.Cells(Rows.Count, "A").End(3).Row
    yil = Format(Now, "yyyy")
    gun = Format(Now, "dd")
    ay = Format(Now, "mm")
    
    If ay = 1 Then
    yil = yil - 1
    ay = 12
    End If
    
    For x = 2 To satirsayisi
    If Format(s1.Cells(x, starih), "yyyy") < yil Then
    s1.Rows(x).Delete
    x = x - 1
    End If
    Next x
    
    Application.ScreenUpdating = True

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodu deneyin.
Eğer olmazsa dosyanızı ekleyin kontrol edelim.

    Application.ScreenUpdating = False
    Set s1 = Worksheets("RAPOR")
    starih = WorksheetFunction.Match("TARIH", s1.Range("A1:CC1"), 0)
    satirsayisi = s1.Cells(Rows.Count, "A").End(3).Row
    yil = Format(Now, "yyyy")
    gun = Format(Now, "dd")
    ay = Format(Now, "mm")
    
    If ay = 1 Then
        yil = yil - 1
        ay = 12
    End If
    
    Dim Bak As Long
    Dim Satir As Long
    Satir = -1
    For Bak = satirsayisi To 2 Step -1
        If Year(s1.Cells(Bak, "b")) < yil  Then
            If Satir <= 0 Then Satir = Bak
        ElseIf Satir > 0 And Year(s1.Cells(Bak, "b")) >= yil Then
            s1.Rows(Bak + 1 & ":" & Satir).Delete
            Satir = 0
        End If
    Next
    If Satir > 0 Then
        Rows(Bak + 1 & ":" & Satir).Delete
    End If
    Application.ScreenUpdating = True

 

[ÖmerBey]

Merhaba,
Alternatif,

Application.ScreenUpdating = False

    Set s1 = Worksheets("RAPOR")
    
    starih = WorksheetFunction.Match("TARIH", s1.Range("A1:CC1"), 0)
    
    satirsayisi = s1.Cells(Rows.Count, "A").End(3).Row
    yil = Format(Now, "yyyy")
    gun = Format(Now, "dd")
    ay = Format(Now, "mm")
    
    If ay = 1 Then
    yil = yil - 1
    ay = 12
    End If
    
    Set sil = s1.Cells(satirsayisi + 1, "A")
    For x = 2 To satirsayisi
    If Format(s1.Cells(x, starih), "yyyy") < yil Then
    's1.Rows(x).Delete
    'x = x - 1
    Set sil = Union(sil, s1.Cells(x, "A"))
    End If
    Next x
    sil.EntireRow.Delete
    Application.ScreenUpdating = True

Dilerseniz tarihe göre filtre uygulayıp satırları topluca silebilirsiniz.

 

[tuvons]

Çok teşekkürler @Muzaffer Ali ve @ÖmerBey

@ÖmerBey in yazdığı işe yaradı.

 

[Korhan Ayhan]

Merhaba,

Eğer RAPOR sayfasında formüllü hücreleriniz yoksa satır silmek yerine alanı diziye alıp uygun kayıtları hafızaya alıp alana tekrar yazdırmak daha hızlı sonuç verecektir.

Sayfanız bold koşula uygunsa aşağıdaki kodu denersiniz.

Sub Test()
    Application.ScreenUpdating = False

    Zaman = Timer

    Set s1 = Worksheets("RAPOR")
   
    starih = WorksheetFunction.Match("TARIH", s1.Range("A1:CC1"), 0)
   
    satirsayisi = s1.Cells(Rows.Count, "A").End(3).Row
    If satirsayisi < 3 Then satirsayisi = 3
   
    yil = Format(Now, "yyyy")
    gun = Format(Now, "dd")
    ay = Format(Now, "mm")
   
    If ay = 1 Then
    yil = yil - 1
    ay = 12
    End If
   
    Veri = s1.Range("A2:CC" & satirsayisi).Value
   
    ReDim Liste(1 To satirsayisi - 1, 1 To 81)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Format(Veri(X, starih), "yyyy") > yil Then
            Say = Say + 1
            For Y = 1 To 81
                Liste(Say, Y) = Veri(X, Y)
            Next
        End If
    Next
   
    If Say > 0 Then
        s1.Range("A2:CC" & s1.Rows.Count).ClearContents
        s1.Range("A2").Resize(Say, UBound(Liste, 2)) = Liste
    End If
   
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[tuvons]

@Korhan Ayhan çok teşekkür ederim. Benim çalışma dosyamda 71 sütun var. Silme işleminden sonra da diğer alanlarla işlem yapıyorum. Onun için dizi işlevini kullanamayacağım. Yardımlarınız için çok teşekkür ederim.