Altalta toplayarak ilerleme

[ikikan]

Altalta toplayarak ilerleme (konu ek)

Korhan Beyin Düzenlediği koda ek olarak birkaç ekleme yaptım.
Süzülen veriye göre başlıkları alıp toplama işlemi yapıyor fakat kırmızı ile işaretlediğim kodu kısaltmak istiyorum dizi içine almayı denedim beceremedim yardımcı olacak arkadaşlara şimdiden teşekkürler.

Sub ToplaBakiye3()
    Dim KTP As Worksheet, Zaman As Double
    Dim y, x, e, r, k, Bakiye, SSA, SSU, Say, Sayac As Long
    Dim Dizim(), Kriter(), VR(), KT(), z(), a(), b() As Variant
    Dim KR(), Birles() As String
    Dim TRH1, TRH2 As Date

    Zaman = Timer
    
    Set KTP = Sheets("ASayfa")


    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        'Application.Volatile
    End With
    
    SSA = KTP.Cells(KTP.Rows.Count, 1).End(xlUp).Row
    SSU = KTP.Cells(10, Columns.Count).End(xlToLeft).Column
            
    KTP.Range("M11:M" & SSA + 30).ClearContents
    VR = KTP.Range("A11:P" & SSA).Value
                    
ReDim KR(KTP.AutoFilter.Filters.Count)
Say = 1
For k = 1 To KTP.AutoFilter.Filters.Count 'Step 1
    'If KTP.AutoFilter.Filters(k).On Then
     KR(Say) = KTP.Cells(9, k) 'Replace(KTP.AutoFilter.Filters(k).Criteria1, "=", "", 1)
     Say = Say + 1
    'End If
Next k
  
                    TRH1 = KTP.[D5]
                    TRH2 = KTP.[E5]
     
    On Error Resume Next
    KTP.ShowAllData
    On Error GoTo 0

ReDim a(UBound(KR))
ReDim z(UBound(VR))

ReDim Dizim(1 To UBound(VR, 1), 1 To UBound(KR))

For y = 1 To UBound(KR, 1)
Bakiye = 0
    If Not KR(y) = "" Then
    For x = 1 To UBound(VR, 1)
        ReDim Preserve Dizim(1 To UBound(VR, 1), 1 To UBound(KR, 1))
        On Error Resume Next
          
            For r = 1 To y
                a(r) = VR(x, r) = KR(r)
            Next r
[COLOR="DarkRed"][COLOR="Red"]z(1) = a(1)
z(2) = a(1) And a(2)
z(3) = a(1) And a(2) And a(3)
z(4) = a(1) And a(2) And a(3) And a(4)
z(5) = a(1) And a(2) And a(3) And a(4) And a(5)
z(6) = a(1) And a(2) And a(3) And a(4) And a(5) And a(6)
z(7) = a(1) And a(2) And a(3) And a(4) And a(5) And a(6) And a(7)
z(8) = a(1) And a(2) And a(3) And a(4) And a(5) And a(6) And a(7) And a(8)[/COLOR][/COLOR]

        If z(y) Then
        Dizim(x, 1) = Bakiye + (VR(x, 11) - VR(x, 12))
        Bakiye = Dizim(x, 1)
        End If

Next x
End If
Next y

KTP.Range("M11:M" & UBound(Dizim) + 10) = Dizim

For y = 1 To UBound(KR, 1)
  If Not KR(y) = "" Then: KTP.Range("A10:P" & SSA).AutoFilter y, KR(y)
Next y

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    
KTP.Cells(1, 1) = "Sure:" & Format(Timer - Zaman, "0.00000")
Set KTP = Nothing
End Sub