Vba ile Özet Tablo oluşturma hk.

[Vkaraaslan]

[TR][TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD][/TR]
[TR][TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD][/TR]

 

[Vkaraaslan]

özet tablo

ekteki dosyayı veresiye ve tahsilat tutarlarına göre özetleme yapmak istiyorum konu ile ilgili yardımcı olur musunuz Şimdiden Teşekkürler

 

[Vkaraaslan]

Şöyleki A sütünunda ve B sutununda isim ve ıd numaralarım aynı benım ıstedıgım bu ıd veya ısımler veresiye ve tahsılat işlemine göre özetlenmesi!!!

 

[Vkaraaslan]

özet tablo dosyası

Lütfen yardım

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz:

Sub ozetle()
son = Cells(Rows.Count, "A").End(3).Row
eski = WorksheetFunction.Max(2, Cells(Rows.Count, "P").End(3).Row)
Range("P2:S" & eski).ClearContents
Range("B2:B" & son).Copy [P2]
Range("$P$1:$P$" & son).RemoveDuplicates Columns:=1, Header:=xlYes
yeni = WorksheetFunction.Max(2, Cells(Rows.Count, "P").End(3).Row)
For i = 2 To yeni
    Cells(i, "Q") = WorksheetFunction.SumIf(Range("B1:B" & son), Cells(i, "P"), Range("G1:G" & son))
    Cells(i, "R") = WorksheetFunction.SumIf(Range("B1:B" & son), Cells(i, "P"), Range("N1:N" & son))
    Cells(i, "S") = Cells(i, "Q") - Cells(i, "R")
Next
Range("Q2:S" & yeni).NumberFormat = "#,##0.00 $"
End Sub

 

[Vkaraaslan]

Yusuf bey ellerinize sağlık çok teşekkür ederim Son bir sey daha rica etsem Bakiye "0" Sıfır verenler özetleme de çıkmamasını sağlayabilirmiyiz??

 

[YUSUF44]

End Sub satırından önce aşağıdaki satırları ekleyip dener misiniz?

For j = yeni to 2 Step -1
    If Cells(j,"S") = 0 Then
        Range("P" & j & ":S" & j).Delete Shift:=XLUP
    End if
Next

 

[Korhan Ayhan]

Alternatif,

Yoğun veride hız olarak biraz daha iyi sonuç verecektir.

Option Explicit

Sub Ozet_Tablo()
    Dim Veri As Variant, Son As Long, X As Long, Zaman As Double
    Dim Dizi As Object, Aranan As String, Say As Long
    
    Application.ScreenUpdating = False
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A2:N" & Son).Value
    
    Range("P2:S" & Rows.Count).ClearContents
    
    ReDim Liste(1 To UBound(Veri), 1 To 4)
    
    For X = 1 To UBound(Veri)
        Aranan = Veri(X, 2)
        If Not Dizi.Exists(Aranan) Then
            Say = Say + 1
            Dizi.Add Aranan, Say
            ReDim Preserve Liste(1 To UBound(Veri), 1 To 4)
            Liste(Say, 1) = Aranan
            Liste(Say, 2) = Veri(X, 7)
            Liste(Say, 3) = Veri(X, 14)
            Liste(Say, 4) = Liste(Say, 2) - Liste(Say, 3)
        Else
            Liste(Dizi.Item(Aranan), 2) = Liste(Dizi.Item(Aranan), 2) + Veri(X, 7)
            Liste(Dizi.Item(Aranan), 3) = Liste(Dizi.Item(Aranan), 3) + Veri(X, 14)
            Liste(Dizi.Item(Aranan), 4) = Liste(Dizi.Item(Aranan), 2) - Liste(Dizi.Item(Aranan), 3)
        End If
    Next
        
    ReDim Son_Liste(1 To UBound(Liste), 1 To 4)
    Say = 0
    
    For X = 1 To UBound(Liste)
        If Liste(X, 4) <> 0 Then
            Say = Say + 1
            ReDim Preserve Son_Liste(1 To UBound(Liste), 1 To 4)
            Son_Liste(Say, 1) = Liste(X, 1)
            Son_Liste(Say, 2) = Liste(X, 2)
            Son_Liste(Say, 3) = Liste(X, 3)
            Son_Liste(Say, 4) = Liste(X, 4)
        End If
    Next
    
    Range("P2").Resize(Say, 4) = Son_Liste
    Range("Q2").Resize(Say, 3).Style = "Currency"
    Range("P:S").Columns.AutoFit
            
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00") & " Saniye"
End Sub

 

[Vkaraaslan]

Korhan bey sizinde emeğinize sağlık teşekkürler 0,02 sn işlem tamamlanıyor süper !!!!