Kodlarda revize

[1903emre34@gmail.com]

Merhaba,

"C" sütündaki ara toplam 1 100, 102 vs devam etmektedir, sayfa2'ye ara toplam 1 den sonra yer alan hesap kodların 100,102 sayfa2 'e ana sayfa altına yerleştirilmesi, karşısında bakiye devri+rapor dönemi borç toplamı alınması (siyah işaretler) ve rapor dönemi alacak bakiyesi aynen sayfa2 aktarılmasın istiyorum, kodlar çalışmadı.
istenen sayfa2'de yapılmıştır.

Option Explicit
Sub aktar()
Dim a(), b(), deg As Variant
Dim i As Long, Say As Long, S1 As Worksheet, S2 As Worksheet
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
a = S1.Range("A2:I" & S1.Cells(Rows.Count, 1).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 4)
    For i = 1 To UBound(a)
        deg = "Ara toplam*"
        If a(i, 1) Like deg Then
            Say = Say + 1
            b(Say, 1) = Right(a(i, 1), 3)
            b(Say, 2) = a(i, 5) + a(i, 7)
            b(Say, 3) = a(i, 8)
            b(Say, 4) = a(i, 9)
        End If
    Next i
    Application.ScreenUpdating = False
    If Say > 0 Then
        S2.Select
        S2.Range("B2:E" & Rows.Count).ClearContents
        S2.[B2].Resize(Say, 4) = b
        S2.[C2].Resize(Say, 3).NumberFormat = "#,##0.00"
    End If
    Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

 

[Ziynettin]

Merhaba,

Sub ara_toplam()
Dim a(), b(), deg As Variant
Dim i As Long, Say As Long, S1 As Worksheet, S2 As Worksheet
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
a = S1.Range("A2:S" & S1.Cells(Rows.Count, 1).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 4)
    For i = 1 To UBound(a)
        deg = "Ara toplam*"
        If a(i, 3) Like deg Then
            Say = Say + 1
            b(Say, 1) = Right(a(i, 3), 3)
            b(Say, 2) = a(i, 12) + a(i, 16)
            b(Say, 3) = a(i, 18)
            b(Say, 4) = a(i, 19)
        End If
    Next i
    Application.ScreenUpdating = False
    If Say > 0 Then
        S2.Select
        S2.Range("C5:F" & Rows.Count).ClearContents
        S2.[C5].Resize(Say, 4) = b
        S2.[D5].Resize(Say, 3).NumberFormat = "#,##0.00"
    End If
    Application.ScreenUpdating = True
MsgBox "işlem tamam", vbInformation
End Sub

 

[1903emre34@gmail.com]

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