VBA code to find the sum of unique elements in a range - excel

Question

I have 2 columns and need a VBA code to sum the values of unique elements in column "A", print the unique elements in column "D" and sum in column "E" :-
Name Value Name Sum
A 1 A 13
A 2 B 7
B 1 C 3
B 3
C 2
A 1
B 2
A 3
B 1
A 2
A 4
C 1
Can anyone help on this, this is what I tried :-
Sub CountSum()
Dim c As Collection, wf As WorksheetFunction, _
K As Long, N As Long, i As Long, _
v As Variant, d As Collection, y As Variant
Set c = New Collection
Set d = New Collection
Set wf = Application.WorksheetFunction
K = 2
N = Cells(Rows.Count, "A").End(xlUp).Row
On Error Resume Next
For i = 2 To N
v = Cells(i, "A").Value
y = Cells(i, "B").Value
c.Add v, CStr(v)
d.Add y
If Err.Number = 0 Then
Cells(K, "D").Value = v
Cells(K, "E").Value = wf.CountIf(Range("A:A"), v)
Cells(K, "F").Value = wf.Sum(Range("B:B"), y)
K = K + 1
Else
Err.Number = 0
End If
Next i
On Error GoTo 0
End Sub

Answer 1

Using a Dictionary:
Sub Tester()
Dim rng As Range, dict As Object
Set rng = Range(Range("A2"), Cells(Rows.Count, 1).End(xlUp)).Resize(, 2)
Set dict = SubTotals(rng, 1, 2)
DumpDict dict, Range("D1")
End Sub
Function SubTotals(rng As Range, colKey As Long, colVal As Long) As Object
Dim rv As Object, rw As Range, k, v
Set rv = CreateObject("scripting.dictionary")
For Each rw In rng.Rows
k = rw.Cells(colKey).Value
v = rw.Cells(colVal).Value
If Not IsError(k) And Not IsError(v) Then
If Len(k) > 0 And IsNumeric(v) Then
rv(k) = rv(k) + v
End If
End If
Next rw
Set SubTotals = rv
End Function
Sub DumpDict(dict As Object, rng As Range)
Dim i As Long, k
i = 0
For Each k In dict.keys
With rng.Cells(1)
.Offset(i, 0).Value = k
.Offset(i, 1).Value = dict(k)
End With
i = i + 1
Next
End Sub

Answer 2

next code works for me, I hope this will help you. This will work perfectly if at column A there are not blank cells between values.
Sub SUM()
Dim i, j, k As Integer
i = 2
j = 2
Range("D1").Value = "NAME"
Range("E1").Value = "VALUE"
'copy the first value of column A to column D
Range("D2").Value = Range("A2").Value
'cycle to read all values of column B and sum it to column E; will run until find a blank cell
While Range("A" & i).Value <> ""
'this check if actual value of column A is equal to before value of column A, if true just add the column B value to E
'else, look for the row in column D where is the same value of column A, if it doesn't exist code create the value
'in column D and E
If Range("A" & i).Value = Range("A" & i - 1).Value Then
Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
Else
flag = 1
While Range("D" & flag).Value <> ""
If Range("A" & i).Value = Range("D" & flag).Value Then
j = flag
Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
flag = Range("D1").End(xlDown).Row
Else
j = 0
End If
flag = flag + 1
Wend
If j = 0 Then
Range("D1").End(xlDown).Offset(1, 0).Value = Range("A" & i).Value
Range("E1").End(xlDown).Offset(1, 0).Value = Range("B" & i).Value
j = Range("E1").End(xlDown).Row
End If
End If
i = i + 1
Wend
MsgBox "End"
End Sub