DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
=TOPLA.ÇARPIM((A2:A6=200150)*(B2:C6))
Option Base 1
Sub aktar59()
Dim sat As Long, liste(), myarr(), n As Long, i As Long
Dim z As Object
Sheets("Sayfa1").Select
Range("F:H").ClearContents
Application.ScreenUpdating = False
Set z = CreateObject("Scripting.Dictionary")
sat = Cells(Rows.Count, "A").End(xlUp).Row
liste = Range("A2:C" & sat).Value
sat = UBound(liste)
ReDim myarr(1 To 3, 1 To sat)
For i = 1 To sat
If Not z.exists(liste(i, 1)) Then
n = n + 1
z.Add (liste(i, 1)), n
myarr(1, n) = liste(i, 1)
End If
myarr(2, z.Item(liste(i, 1))) = myarr(2, z.Item(liste(i, 1))) + liste(i, 2)
myarr(3, z.Item(liste(i, 1))) = myarr(3, z.Item(liste(i, 1))) + liste(i, 3)
Next i
Erase liste
ReDim Preserve myarr(1 To 3, 1 To n)
Range("F2").Resize(n, 3) = Application.Transpose(myarr)
Set z = Nothing
Erase myarr
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com", _
vbOKOnly, Application.UserName
End Sub