DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub aktar()
Dim a, i As Long, z As Object
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
'*******************************************************
a = s1.Range("a2:b" & s1.Cells(65536, "A").End(xlUp).Row)
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a, 1)
If Not z.exists(a(i, 1)) Then
z.Add a(i, 1), CDbl(a(i, 2))
Else
z.Item(a(i, 1)) = z.Item(a(i, 1)) + CDbl(a(i, 2))
End If
Next i
Application.ScreenUpdating = False
s2.Range("A2:B65536").ClearContents
s2.[A2].Resize((z.Count), 2) = Application.Transpose(Array(z.keys, z.items))
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı"
End Sub