Toplamları sıfır olanları diğer sayfada listeleme

[ugurbocegii]

Ekteki göndermiş olduğum listede bulunan verilerde toplamları sıfır olan sınıfları farklı olan verileri sayfa,sayfa ayıraması gerekiyor.

Ilginiz için teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim S4 As Worksheet, S5 As Worksheet, X As Long
    Dim Satır_S2 As Long, Satır_S3 As Long
    Dim Satır_S4 As Long, Satır_S5 As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("ARAÇ BENZİN ÖDEMELERİ")
    Set S2 = Sheets("TAŞIT TANIMA İLE")
    Set S3 = Sheets("NAKİT YOLU İLE")
    Set S4 = Sheets("KREDİ KARTI İLE")
    Set S5 = Sheets("GENEL TOPLAM")
    
    S2.Range("A3:G" & Rows.Count).Clear
    S3.Range("A3:G" & Rows.Count).Clear
    S4.Range("A3:G" & Rows.Count).Clear
    S5.Range("A3:G" & Rows.Count).Clear
    
    Satır_S2 = 3
    Satır_S3 = 3
    Satır_S4 = 3
    Satır_S5 = 3
    
    For X = 4 To S1.Cells(Rows.Count, 1).End(3).Row
        If S1.Cells(X, "G") = 0 Then
            S2.Range("A" & Satır_S2 & ":G" & Satır_S2).Value = S1.Range("A" & X & ":G" & X).Value
            S5.Range("A" & Satır_S5 & ":G" & Satır_S5).Value = S1.Range("A" & X & ":G" & X).Value
            Satır_S2 = Satır_S2 + 1
            Satır_S5 = Satır_S5 + 1
        End If
        
        If S1.Cells(X, "M") = 0 Then
            S4.Range("A" & Satır_S4).Value = S1.Range("A" & X).Value
            S4.Range("B" & Satır_S4 & ":G" & Satır_S4).Value = S1.Range("H" & X & ":M" & X).Value
            S5.Range("A" & Satır_S5).Value = S1.Range("A" & X).Value
            S5.Range("B" & Satır_S5 & ":G" & Satır_S5).Value = S1.Range("H" & X & ":M" & X).Value
            Satır_S4 = Satır_S4 + 1
            Satır_S5 = Satır_S5 + 1
        End If
        If S1.Cells(X, "S") = 0 Then
            S3.Range("A" & Satır_S3).Value = S1.Range("A" & X).Value
            S3.Range("B" & Satır_S3 & ":G" & Satır_S3).Value = S1.Range("N" & X & ":S" & X).Value
            S5.Range("A" & Satır_S5).Value = S1.Range("A" & X).Value
            S5.Range("B" & Satır_S5 & ":G" & Satır_S5).Value = S1.Range("N" & X & ":S" & X).Value
            Satır_S3 = Satır_S3 + 1
            Satır_S5 = Satır_S5 + 1
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    Set S5 = Nothing
 
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub