ikikan
Altın Üye
- Katılım
- 3 Mart 2009
- Mesajlar
- 519
- Excel Vers. ve Dili
- excel 2003 tr
- Altın Üyelik Bitiş Tarihi
- 12.02.2026
Öncelikle kolay gelsin arakadaşlar.
Bu kodu kısaltmak veya hızlandırmak mümkün mü?
Bu kodu kısaltmak veya hızlandırmak mümkün mü?
Kod:
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