Müşteri alışları ve geri ödemelerini tek listede göstermek.

[tufan03]

Ekli dosyada müşterilerin veresi alışları ve borç ödemeleri var,yıl sonunda ister aynı sayfa üzerinde isterse yeni açılacak bir sayfada herbir müşterinin borç ve geri ödeme miktarlarını tek satırda göstermek istiyorum. Makro ile olursa iyi olur.

Eğer mümkünse borç ve ödemeleri mahsuplaştırarak borç veya alacak kalanını yazdırmak çok iyi olur. Teşekkür ederim.

 

[Recep İpek]

Aşağıdaki kodları deneyebilir misiniz?

Sub Raporla()
Dim a, b, i, n, sat, veri()
Set s1 = Sheets("YEV")
Set s2 = Sheets("RAPOR")
'*******************************************
a = s1.Range("a4:g" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 7)
'*******************************************
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
       z = a(i, 1) & ":" & Year(a(i, 3))
           If Not IsEmpty(z) Then
                 If Not .exists(z) Then
                    n = n + 1
                    veri(n, 1) = a(i, 1)
                    veri(n, 2) = a(i, 2)
                    veri(n, 3) = Year(a(i, 3))
                    .Add z, n
                  End If
                    veri(.Item(z), 4) = veri(.Item(z), 4) + a(i, 4)
                    veri(.Item(z), 5) = veri(.Item(z), 5) + a(i, 5)
                    veri(.Item(z), 6) = veri(.Item(z), 6) + a(i, 6)
                    veri(.Item(z), 7) = veri(.Item(z), 7) + a(i, 7)
            End If
    Next i
End With
'*******************************************
sat = s2.[b65536].End(3).Row + 1
s2.Range(s2.Cells(2, "a"), s2.Cells(sat, "g")).ClearContents
s2.[a2].Resize(n, 7).Value = veri
''*******************************************
sat = s2.[b65536].End(3).Row + 1
s2.Range(s2.Cells(2, "a"), s2.Cells(sat, "g")).Sort Key1:=s2.Range("A2"), Order1:=xlAscending, Key2:=s2.Range("C2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
s2.Range("B2").Select
''*******************************************
s2.Select
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub