Ömer Bey başka bir yerden aşağıdaki makro geldi paylaşmak istedim:
Sub test()
Dim s1 As Worksheet, s2 As Worksheet
Dim a(), b(), d As Object, say As Long, y As Byte, sat As Long
Dim i As Long, kosul As String, krt As String
Set s1 = Sheets("FASON")
Set s2 = Sheets("RAPOR")
Set d = CreateObject("scripting.dictionary")
kosul = "FASON"
s2.Range("A3:J" & Rows.Count).Clear
a = s1.Range("B3:M" & s1.Cells(Rows.Count, 2).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 10)
For i = 1 To UBound(a)
If kosul = a(i, 1) Then
krt = a(i, 2)
If Not d.exists(krt) Then
d(krt) = d.Count + 1
say = d.Count
b(say, 1) = krt
End If
sat = d(krt)
For y = 2 To 9
b(sat, y) = b(sat, y) + a(i, y + 3)
b(sat, 10) = b(sat, 10) + a(i, y + 3)
Next y
End If
Next i
If say > 0 Then
For i = 1 To say
For y = 2 To 10
b(say + 1, y) = b(say + 1, y) + b(i, y)
Next y
Next i
s2.[A3].Resize(say + 1, 10) = b
s2.[A3].Offset(say) = "TOPLAM"
s2.[A3].Resize(say + 1, 10).Borders.Color = 1
s2.[A3].Offset(say).Resize(, 10).BorderAround , xlMedium
End If
MsgBox "İşlem bitti..", vbInformation
End Sub
