Hesap kodları toplamın alınması

[1903emre34@gmail.com]

Merhaba,

Daha önce bu konuyla benzer konu açmıştım, kodları denedim ama olmadı, ana hesaptaki ilk üç kodu toplayıp pozitif tutarlar sayfa2'de borç bakiyesinin altında, negatif sayılar alacak bakiyesine yerleşece şekilde kodlarda nasıl değişiklik yapabiliriz, istenen sayfa2'de yapılmıştır.

Sub test()
Dim s1 As Worksheet, s2 As Worksheet
Dim a(), b(), dic As Object, i As Long, say As Long
Dim sat As Long
Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")
Set dic = CreateObject("scripting.dictionary")
a = s1.Range("B7:I" & s1.Cells(Rows.Count, 2).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 3)
For i = 1 To UBound(a)
If a(i, 1) <> "" Then
krt = Left(a(i, 1), 3)
If Not IsEmpty(krt) And Not dic.exists(krt) Then
dic(krt) = dic.Count + 1
say = dic.Count
b(say, 1) = krt
End If
sat = dic(krt)
If a(i, 8) >= 0 Then b(sat, 2) = b(sat, 2) + a(i, 8)
If a(i, 8) < 0 Then b(sat, 3) = b(sat, 3) + a(i, 8) * -1
End If
Next i
s2.Range("D6:F" & Rows.Count).ClearContents
If say > 0 Then
s2.[D6].Resize(say, 3) = b
End If
s2.Select
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[Ziynettin]

Sub test()
Dim s1 As Worksheet, s2 As Worksheet
Dim a(), b(), dic As Object, i As Long, say As Long
Dim sat As Long
Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")
Set dic = CreateObject("scripting.dictionary")
    a = s1.Range("C7:J" & s1.Cells(Rows.Count, 2).End(3).Row).Value
    ReDim b(1 To UBound(a), 1 To 3)
        For i = 1 To UBound(a)
            If a(i, 1) <> "" Then
                krt = Left(a(i, 1), 3)
                If Not IsEmpty(krt) And Not dic.exists(krt) Then
                    dic(krt) = dic.Count + 1
                    say = dic.Count
                    b(say, 1) = krt
                End If
                sat = dic(krt)
                If a(i, 8) >= 0 Then b(sat, 2) = b(sat, 2) + a(i, 8)
                If a(i, 8) < 0 Then b(sat, 3) = b(sat, 3) + a(i, 8) * -1
            End If
        Next i
    s2.Range("C5:F" & Rows.Count).ClearContents
    If say > 0 Then
        s2.[C5].Resize(say, 3) = b
    End If
    s2.Select
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[1903emre34@gmail.com]

Teşekkürler, çalışıyor.