her carinin borç alacak tutar farkının oluşturulması

[spacebar]

değerli üstadlarım. yapılmak istenen cari listesinde bulunan carilerin borç alacak tutar farkının oluşturulması. ben pivot ile bunu oluşturdum. ancak pivotsuz da çözümlenebilir. yardımlarınız için teşekkür ederim.

 

[veyselemre]

Sub test()
    Dim veri, liste, son&, sira&, say&, fltr%, i&, _
    ky1$, ky2$, toplaA As Double, toplaB As Double
    With CreateObject("Scripting.Dictionary")
        son = Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row
        veri = Sheets("Sheet1").Range("A2:Z" & son).Value
        
        ReDim liste(1 To son * 2, 1 To 5)
        fltr = 1
       
        For i = 1 To son - 1
            If veri(i, 25) = fltr Then
                ky1 = veri(i, 2) & "|" & veri(i, 2)
                ky2 = veri(i, 2) & "|" & veri(i, 1)
                If Not .exists(ky1) Then
                    say = say + 1
                    liste(say, 1) = veri(i, 2)
                    liste(say, 2) = veri(i, 2)
                    liste(say, 3) = veri(i, 7)
                    liste(say, 4) = veri(i, 8)
                    liste(say, 5) = 1
                    .Item(ky1) = say
                    
                    say = say + 1
                    liste(say, 1) = veri(i, 2)
                    liste(say, 2) = veri(i, 1)
                    liste(say, 3) = veri(i, 7)
                    liste(say, 4) = veri(i, 8)
                    .Item(ky2) = say
                Else
                    sira = .Item(ky1)
                    liste(sira, 3) = liste(sira, 3) + veri(i, 7)
                    liste(sira, 4) = liste(sira, 4) + veri(i, 8)
                    If Not .exists(ky2) Then
                        say = say + 1
                        liste(say, 1) = veri(i, 2)
                        liste(say, 2) = veri(i, 1)
                        liste(say, 3) = veri(i, 7)
                        liste(say, 4) = veri(i, 8)
                        .Item(ky2) = say
                    Else
                        sira = .Item(ky2)
                        liste(sira, 3) = liste(sira, 3) + veri(i, 7)
                        liste(sira, 4) = liste(sira, 4) + veri(i, 8)
                    End If
                End If
            End If
        Next i
    End With
    With Sheets("Sheet2")
        .Range("A2:D" & Rows.Count).Clear
        .Range("A2:E" & say + 1).Value = liste
        son = .Cells(Rows.Count, 1).End(3).Row
        .Range("A2:E" & son).Sort .Range("A2"), , .Range("E2"), , , , , xlNo
        .Range("C2:D" & son + 1).NumberFormat = "#,##0.00"
        For i = 2 To son
            If .Cells(i, "B").Value = .Cells(i, "A").Value Then
                .Cells(i, "B").Resize(, 3).Font.Bold = True
                toplaA = toplaA + .Cells(i, "C").Value
                toplaB = toplaB + .Cells(i, "D").Value
            Else
                .Cells(i, "B").IndentLevel = 1
            End If
        Next i
        .Cells(son + 1, "C").Value = toplaA
        .Cells(son + 1, "D").Value = toplaB
        .Cells(son + 1, "B").Value = "TOPLAM"
        .Cells(son + 1, "B").Resize(, 3).Font.Bold = True
        .Range("E:E").Delete
        .Range("A:A").Delete
        .Columns.AutoFit
    End With
End Sub

 

[spacebar]

üstad bir de bakiyeyi getirme imkanı varmı acaba. yani borç tutarlarından alacak tutarlarını çıkarak şekilde.

 

[veyselemre]

Sub test()
    Dim veri, liste, son&, sira&, say&, fltr%, i&, _
    ky1$, ky2$, toplaA As Double, toplaB As Double
    With CreateObject("Scripting.Dictionary")
        son = Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row
        veri = Sheets("Sheet1").Range("A2:Z" & son).Value
        
        ReDim liste(1 To son * 2, 1 To 6)
        fltr = 1
       
        For i = 1 To son - 1
            If veri(i, 25) = fltr Then
                ky1 = veri(i, 2) & "|" & veri(i, 2)
                ky2 = veri(i, 2) & "|" & veri(i, 1)
                If Not .exists(ky1) Then
                    say = say + 1
                    liste(say, 2) = veri(i, 2)
                    liste(say, 3) = veri(i, 2)
                    liste(say, 4) = veri(i, 7)
                    liste(say, 5) = veri(i, 8)
                    liste(say, 1) = 1
                    .Item(ky1) = say
                    
                    say = say + 1
                    liste(say, 2) = veri(i, 2)
                    liste(say, 3) = veri(i, 1)
                    liste(say, 4) = veri(i, 7)
                    liste(say, 5) = veri(i, 8)
                    .Item(ky2) = say
                Else
                    sira = .Item(ky1)
                    liste(sira, 4) = liste(sira, 4) + veri(i, 7)
                    liste(sira, 5) = liste(sira, 5) + veri(i, 8)
                    If Not .exists(ky2) Then
                        say = say + 1
                        liste(say, 2) = veri(i, 2)
                        liste(say, 3) = veri(i, 1)
                        liste(say, 4) = veri(i, 7)
                        liste(say, 5) = veri(i, 8)
                        .Item(ky2) = say
                    Else
                        sira = .Item(ky2)
                        liste(sira, 4) = liste(sira, 4) + veri(i, 7)
                        liste(sira, 5) = liste(sira, 5) + veri(i, 8)
                    End If
                End If
            End If
        Next i
    End With
    With Sheets("Sheet2")
        .Range("A2:E" & Rows.Count).Clear
        .Range("A2:F" & say + 1).Value = liste
        son = .Cells(Rows.Count, 3).End(3).Row
        .Range("A2:E" & son).Sort .Range("B2"), , .Range("A2"), , , , , xlNo
        .Range("C2:F" & son + 1).NumberFormat = "#,##0.00"
        For i = 2 To son
            If .Cells(i, "B").Value = .Cells(i, "C").Value Then
                .Cells(i, "C").Resize(, 4).Font.Bold = True
                toplaB = toplaB + .Cells(i, "D").Value
                toplaA = toplaA + .Cells(i, "E").Value
            Else
                .Cells(i, "C").IndentLevel = 1
            End If
            .Cells(i, "F").Value = .Cells(i, "D").Value - .Cells(i, "E").Value
        Next i
        With .Cells(son + 1, "C").Resize(, 4)
            .Value = Array("TOPLAM", toplaB, toplaA, toplaB - toplaA)
            .Font.Bold = True
        End With
        .Range("A:B").Delete
        .Columns.AutoFit
    End With
End Sub

 

[spacebar]

üstad teşekkür ederim. ellerinize sağlık.