Fonksiyonlarla yapılması biraz uzun ve dosyanızda da fazla veri varsa makro ile çözüm aramanız daha uygun olacaktır.
Bunun için aşağıdaki kodları kullanabilirsiniz.
Kod:
Sub AktarTopla()
Dim a, i, n, k, b()
Set s1 = Sheets("DATA1")
Set s2 = Sheets("DATA2")
'*******************************************
a = s1.Range("a5:e" & s1.[a65536].End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 6)
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(a, 1)
If Not IsEmpty(a(i, 1)) Then
If Not .exists(a(i, 1)) Then
n = n + 1
b(n, 1) = n
b(n, 2) = a(i, 1)
b(n, 3) = a(i, 2)
.Add a(i, 1), n
End If
b(.Item(a(i, 1)), 4) = b(.Item(a(i, 1)), 4) + a(i, 3)
b(.Item(a(i, 1)), 5) = b(.Item(a(i, 1)), 5) + a(i, 4)
b(.Item(a(i, 1)), 6) = b(.Item(a(i, 1)), 6) + a(i, 5)
End If
Next
End With
s2.Range("a6:F100").ClearContents
s2.[a6].Resize(n, 6).Value = b
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub
Sizlere daha iyi bir deneyim sunabilmek icin sitemizde çerez konumlandırmaktayız, web sitemizi kullanmaya devam ettiğinizde çerezler ile toplanan kişisel verileriniz Veri Politikamız / Bilgilendirmelerimizde belirtilen amaçlar ve yöntemlerle mevzuatına uygun olarak kullanılacaktır.