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 & "" & son - 1))
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
