Kod hızlandırma kısaltma

[ikikan]

Öncelikle kolay gelsin arakadaşlar.

Bu kodu kısaltmak veya hızlandırmak mümkün mü?

Sub AltToplamBakiye_27_11_2021() 'Rev2 09/04/2023

Dim BorcAlacak() As Variant, GelirGider() As Variant, Kumulatif() As Variant
Dim Veri1() As Variant, Veri2() As Variant, Kriter As Variant
Dim i As Long, x As Long, a As Long, Skolon As Long
Dim ws1 As Worksheet, ws6 As Worksheet
Dim Bakiye As Double, Zaman As Double
Dim myTable As ListObject
Dim Son As Single


Zaman = Timer

Set ws1 = Sheets("CariG")
Set ws6 = Sheets("Tablolar")
Set myTable = ws1.ListObjects("CariT")
Skolon = myTable.DataBodyRange.Columns.Count
Veri1 = ws1.Range("CariT[[PGM-1]:[PGM-12]]").Value
Kriter = ws1.[A1]

With Application
    .ScreenUpdating = False: .Calculation = xlCalculationManual: .EnableEvents = False: .DisplayAlerts = False
End With


myTable.AutoFilter.ShowAllData

'--------------------------------------------------------------------------------------------------------------

    'ReDim BorcAlacak(1 To UBound(Veri, 1), 1 To 1)
    
    ReDim Preserve BorcAlacak(1 To UBound(Veri1, 1), 1 To Skolon)
    ReDim Preserve GelirGider(1 To UBound(Veri1, 1), 1 To Skolon)
        
        For i = 1 To UBound(Veri1, 1)
      
        
                If Mid(Veri1(i, 7), 14, 2) Like "*" & ws6.Range("D20") & "*" Then
                    BorcAlacak(i, 1) = Veri1(i, 2)
                    Else
                    BorcAlacak(i, 1) = ""
                End If
                If Mid(Veri1(i, 7), 14, 2) Like "*" & ws6.Range("D25") & "*" Then
                    BorcAlacak(i, 2) = Veri1(i, 2)
                    Else
                    BorcAlacak(i, 2) = ""
                End If
                If Mid(Veri1(i, 7), 16, 2) Like "*" & ws6.Range("D20") & "*" Then
                    GelirGider(i, 1) = Veri1(i, 2)
                    Else
                    GelirGider(i, 1) = ""
                End If
                If Mid(Veri1(i, 7), 16, 2) Like "*" & ws6.Range("D25") & "*" Then
                    GelirGider(i, 2) = Veri1(i, 2)
                    Else
                    GelirGider(i, 2) = ""
                End If
        Next i
        
    a = UBound(BorcAlacak) + 7
    b = UBound(GelirGider) + 7
    ws1.Range("K8:L" & a).Value = BorcAlacak
    ws1.Range("S8:T" & b).Value = GelirGider
    
    
'--------------------------------------------------------------------------------------------------------------
'ws1.Range("CariT[PGM-13]").ClearContents
myTable.ListColumns("PGM-13").DataBodyRange.ClearContents

If Kriter = "Coklu Tum Secim" Or Kriter = "Coklu Secim" Or Kriter = "Coklu Filitre" Then GoTo Son
Veri1 = ws1.Range("CariT[[PGM-1]:[PGM-12]]").Value
    'ReDim Kumulatif(1 To UBound(Veri, 1), 1 To 1)
        Bakiye = 0
    ReDim Preserve Kumulatif(1 To UBound(Veri1, 1), 1 To Skolon)
        For x = 1 To UBound(Veri1, 1)
            If Veri1(x, 1) = Kriter Then
                Kumulatif(x, 1) = Bakiye + (Veri1(x, 11) - Veri1(x, 12))
                'Kumulatif(x, 1) = Bakiye + (BorcAlacak(x, 1) - BorcAlacak(x, 2))
                Bakiye = Kumulatif(x, 1)
            End If
        Next x
    ws1.Range("M8:M" & UBound(Kumulatif) + 7).Value = Kumulatif
myTable.Range.AutoFilter 1, Kriter

Son:
With Application
     .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: .EnableEvents = True: .DisplayAlerts = True
End With

'MsgBox "Sure:" & Format(Timer - Zaman, "0.00000")

Bakiye = Empty
Kriter = Empty
Set ws1 = Nothing
Set ws6 = Nothing
Set myTable = Nothing

End Sub