Tarihe Göre Toplam Almak

A sütununa formülle veri getirmenize gerek kalmadı kod ile getirip alfabetik sıralattım.
Kod hücrelere tek tek veri eklediği için yavaş biraz ve fazla veri varsa dizi ile hızlandırılır.

Sub Aktar()



    Dim son As Long, i As Long

    Dim syf As Worksheet, bul As Range

    Set syf = ThisWorkbook.Sheets("Sayfa2")

    Const satir_bas As Byte = 2

    Const sifre As String = "123"

    Const genelToplam As String = "GENEL TOPLAM:"

    Const arananTarihHucre As Byte = 14

    

    Application.ScreenUpdating = False

    syf.Unprotect sifre

    tekYapSirala

    With ThisWorkbook.Sheets("Sayfa1")

        syf.Range("B" & satir_bas & ":E" & Rows.Count).ClearContents

        Set bul = syf.Range("B:B").Find(genelToplam, , , 1)

        If Not bul Is Nothing Then

            son = syf.Range("B:B").Find(genelToplam, , , , , xlPrevious).Row - 1

        Else

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

        End If

        

        If son < satir_bas Then Exit Sub

        If son = satir_bas Then son = satir_bas

        For i = satir_bas To son

            If syf.Cells(i, 1).Value <> "" Then syf.Cells(i, 2).Value = .Cells(14, "M").Value

            syf.Cells(i, 3).Value = WorksheetFunction.SumIfs(.Range("D
                                                            .Range("A:A"), syf.Cells(i, 1).Value, _

                                                            .Range("B:B"), .Cells(arananTarihHucre, "M").Value)

            syf.Cells(i, 4).Value = WorksheetFunction.SumIfs(.Range("i:i"), _

                                                            .Range("F:F"), syf.Cells(i, 1).Value, _

                                                            .Range("G:G"), .Cells(arananTarihHucre, "M").Value)

            syf.Cells(i, 5).Value = syf.Cells(i, 3).Value + 0 - syf.Cells(i, 4).Value + 0

        Next

        

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

        syf.Range("B" & son).Value = genelToplam

                

        son = syf.Range("B:B").Find(genelToplam, , , 1).Row

        syf.Range("C" & son).Value = WorksheetFunction.Sum(syf.Range("C" & satir_bas & ":C" & son - 1))

        syf.Range("D" & son).Value = WorksheetFunction.Sum(syf.Range("D" & satir_bas & "
        syf.Cells(son, "E").Value = syf.Cells(son, 3).Value - syf.Cells(son, 4).Value

    End With

    Application.ScreenUpdating = True

    syf.Protect sifre

    Set syf = Nothing: Set bul = Nothing

    MsgBox "Biiti"

UserForm1.Show

End Sub

Sub tekYapSirala()



Dim son1 As Long, aranan As String

Dim son2 As Long, i As Long

Dim dic As Object, dic2 As Object



Set dic = CreateObject("Scripting.dictionary")

Set dic2 = CreateObject("system.collections.arraylist")

With ThisWorkbook.Sheets("Sayfa1")

    son1 = .Range("A:A").Find("*", , , , , xlPrevious).Row

    dic.comparemode = 1

    If son1 < 2 Then GoTo var

    

    For i = 2 To son1

      aranan = .Cells(i, 1).Value

      If Not dic.exists(aranan) Then

        dic.Add aranan, 0

        dic2.Add aranan

      End If

    Next

    

var:

    son2 = .Range("F:F").Find("*", , , , , xlPrevious).Row

    If son2 < 2 Then GoTo var2

    

    For i = 2 To son2

      aranan = .Cells(i, "F").Value

      If Not dic.exists(aranan) Then

        dic.Add aranan, 0

        dic2.Add aranan

      End If

    Next

var2:

    

    If dic2.Count > 0 Then

        dic2.Sort

        ReDim arr(1 To dic2.Count, 1 To 1)

        For i = 0 To dic2.Count - 1

            arr(i + 1, 1) = dic2(i)

        Next

        ThisWorkbook.Sheets("Sayfa2").Range("A3").Resize(dic2.Count, 1).Value = arr

    End If

End With

On Error Resume Next

Erase arr

Set dic = Nothing

Set dic2 = Nothing

On Error GoTo 0

End Sub

Biraz daha hızlısı alttaki.

Sub Aktar()



    Dim son As Long, i As Long

    Dim syf As Worksheet, bul As Range

    Set syf = ThisWorkbook.Sheets("Sayfa2")

    Const satir_bas As Byte = 2

    Const sifre As String = "123"

    Const genelToplam As String = "GENEL TOPLAM:"

    Const arananTarihHucre As Byte = 14

    

    Application.ScreenUpdating = False

    syf.Unprotect sifre

    tekYapSirala

    With ThisWorkbook.Sheets("Sayfa1")

        syf.Range("B" & satir_bas & ":E" & Rows.Count).ClearContents

        Set bul = syf.Range("B:B").Find(genelToplam, , , 1)

        If Not bul Is Nothing Then

            son = syf.Range("B:B").Find(genelToplam, , , , , xlPrevious).Row - 1

        Else

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

        End If

        

        If son < satir_bas Then Exit Sub

        If son = satir_bas Then son = satir_bas

        ReDim arr(1 To son, 1 To 4)

        

        For i = satir_bas To son

            If syf.Cells(i, 1).Value <> "" Then arr(i - 1, 1) = .Cells(14, "M").Value

            

            arr(i - 1, 2) = WorksheetFunction.SumIfs(.Range("D
                                                    .Range("A:A"), syf.Cells(i, 1).Value, _

                                                    .Range("B:B"), .Cells(arananTarihHucre, "M").Value)

                                                  

            arr(i - 1, 3) = WorksheetFunction.SumIfs(.Range("i:i"), _

                                                      .Range("F:F"), syf.Cells(i, 1).Value, _

                                                      .Range("G:G"), .Cells(arananTarihHucre, "M").Value)

                                                      

            arr(i - 1, 4) = arr(i - 1, 2) + 0 - arr(i - 1, 3) + 0

        Next

        

        If UBound(arr) = 0 Then GoTo son

        

        syf.Range("B2").Resize(UBound(arr), 4).Value = arr

        

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

        syf.Range("B" & son).Value = genelToplam

                

        son = syf.Range("B:B").Find(genelToplam, , , 1).Row

        syf.Range("C" & son).Value = WorksheetFunction.Sum(syf.Range("C" & satir_bas & ":C" & son - 1))

        syf.Range("D" & son).Value = WorksheetFunction.Sum(syf.Range("D" & satir_bas & "
        syf.Cells(son, "E").Value = syf.Cells(son, 3).Value - syf.Cells(son, 4).Value

    End With

son:

    Application.ScreenUpdating = True

    syf.Protect sifre

    Set syf = Nothing: Set bul = Nothing



UserForm1.Show

End Sub

Sub tekYapSirala()



Dim son1 As Long, aranan As String

Dim son2 As Long, i As Long

Dim dic As Object, dic2 As Object



Set dic = CreateObject("Scripting.dictionary")

Set dic2 = CreateObject("system.collections.arraylist")

With ThisWorkbook.Sheets("Sayfa1")

    son1 = .Range("A:A").Find("*", , , , , xlPrevious).Row

    dic.comparemode = 1

    If son1 < 2 Then GoTo var

    

    For i = 2 To son1

      aranan = .Cells(i, 1).Value

      If Not dic.exists(aranan) Then

        dic.Add aranan, 0

        dic2.Add aranan

      End If

    Next

    

var:

    son2 = .Range("F:F").Find("*", , , , , xlPrevious).Row

    If son2 < 2 Then GoTo var2

    

    For i = 2 To son2

      aranan = .Cells(i, "F").Value

      If Not dic.exists(aranan) Then

        dic.Add aranan, 0

        dic2.Add aranan

      End If

    Next

var2:

    

    If dic2.Count > 0 Then

        dic2.Sort

        ReDim arr(1 To dic2.Count, 1 To 1)

        For i = 0 To dic2.Count - 1

            arr(i + 1, 1) = dic2(i)

        Next

        ThisWorkbook.Sheets("Sayfa2").Range("A3").Resize(dic2.Count, 1).Value = arr

    End If

End With

On Error Resume Next

Erase arr

Set dic = Nothing

Set dic2 = Nothing

On Error GoTo 0

End Sub

Çok, çok teşekkürler Hocam ellerinize sağlık tam istediğim gibi olmuş.

Hocam konuyu taşıyabilirsiniz. Saygılarımla iyi günler diliyorum.

Rica ederim,kolay gelsin.