Makro İle İcmal Almak

Herkese Merhaba
Toplam sayfası C sütunda benzersiz siciller var
D - P aralığında ay isimleri var.
Bu ay isimleri ile birebir aynı sayfa isimleri mevcut .

Yapamadığım
Ayların isimlerinin olduğu sayfalarda C sütunundaki siciller ile toplam sayfası C sütunundaki siciller aynı ise
1. Işlem: ayların yazılı olduğu sayfalardaki E Sütununda yazan sayı, toplam sayfasındaki ilgili ay sütununun altına ilgili sicilin karşısına yazılacak.
Eğer ilgili ayda o sicil yoksa toplam sayfası ilgili ayın olduğu hücre boş kalacak.
2. Işlem: Toplam sayfası F -Q aralığı toplanıp E sütununa yazılacak .

Merhaba.
Kodun birisi yavaş diğeri ise hızlı çalışır test edin sonuçları.

Sub Test1() 'yavas



Dim syf As Worksheet

Dim i As Long, k As Byte

Dim bul As Range, son As Long



With ThisWorkbook.Sheets("TOPLAM")

    .Range("E3:Q" & Rows.Count).ClearContents

    son = .Range("C:C").Find("*", , , , , xlPrevious).Row + 1

    For Each syf In ThisWorkbook.Sheets

        If syf.Name = "TOPLAM" Then GoTo var

        For k = 6 To 17

            For i = 3 To son

                If .Cells(2, k).Value = syf.Name Then

                    Set bul = syf.Columns(3).Find(.Cells(i, 3).Value, , , 1)

                    If Not bul Is Nothing Then .Cells(i, k).Value = syf.Cells(bul.Row, "E").Value

                End If

            .Cells(i, "E").Value = WorksheetFunction.Sum(.Range(.Cells(i, "F"), .Cells(i, "Q")))

            Next

        Next

var:

    Next

    .Rows(son).ClearContents

End With



Set bul = Nothing

MsgBox ""

End Sub

Sub Test2() 'hizli



Dim syf As Worksheet

Dim i As Long, k As Byte

Dim bul As Range, son As Long



With ThisWorkbook.Sheets("TOPLAM")

    .Range("E3:Q" & Rows.Count).ClearContents

    son = .Range("C:C").Find("*", , , , , xlPrevious).Row + 1

    ReDim arr(1 To son, 1 To 12)

    For Each syf In ThisWorkbook.Sheets

        If syf.Name = "TOPLAM" Then GoTo var

        For k = 6 To 17

            For i = 3 To son

                If .Cells(2, k).Value = syf.Name Then

                    Set bul = syf.Columns(3).Find(.Cells(i, 3).Value, , , 1)

                    If Not bul Is Nothing Then arr(i - 2, k - 5) = syf.Cells(bul.Row, "E").Value

                End If

            Next

        Next

var:

    Next

    If UBound(arr) > 0 Then .Range("F3").Resize(son, 12).Value = arr

    ReDim arr2(1 To son, 1 To 1)

    i = 0

    For i = 3 To son

        arr2(i - 2, 1) = WorksheetFunction.Sum(.Range(.Cells(i, "F"), .Cells(i, "Q")))

    Next

    If UBound(arr2) > 0 Then .Range("E3").Resize(son, 1).Value = arr2

    .Rows(son).ClearContents

End With

On Error Resume Next

Erase arr: Erase arr2

Set bul = Nothing

On Error GoTo 0

MsgBox ""

End Sub

Zafer Hocam siz bu işin üstadısınız. Elinize kolunuza yüreğinize sağlık. Allah'a emanet olun

Rica ederim abey,kolay gelsin.