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 SubSub 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