Mdemir63
Altın Üye
- Katılım
- 7 Temmuz 2006
- Mesajlar
- 2,989
- Excel Vers. ve Dili
- Ofis2010 32Bit Türkçe
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub SehirToplam()
'Microsoft Scripting Runtime Modülü Yüklenmeli
Dim dic As New Dictionary: Dim arr As Variant: Dim i As Long
Dim j As Long: Dim k As Variant: Dim n As Integer
Range("J1").CurrentRegion.Offset(1).ClearContents
arr = Range("A1").CurrentRegion.Value
j = 0
For i = LBound(arr, 1) To UBound(arr)
k = arr(i, 1)
If Not dic.Exists(k) Then
j = j + 1
dic.Add k, j
arr(j, 2) = arr(i, 3)
Else
arr(dic.Item(k), 2) = arr(dic.Item(k), 2) + arr(i, 3)
End If
Next i
Range("J1").Resize(j, 2) = arr
End Sub