# Excel VBA - consolidate column duplicate values into a header and list neighbouring cells below

#### ryouko

##### New Member
Hello all!

I'm a VBA beginner and need to master it for document automation. I wrote some 400 lines of code for this particular project and got stuck on this particular problem. I tried using double for loop and If WorksheetFunction.CountIf, but it creates a new column for each value in A, not consolidates unique ones into one column..

The title might be confusing, so let me explain what should happen:

I have a table A10:C10. For every unique value in A1:A10, it should create a new column and use this unique value as the header of the new column, then list all the unique values from matching row in the next column(B1:B10 in this example). Each new column should also have a sum of # count from C1:C10 and prefix this to the header. Please see the snap of example worksheet for clarity:

### Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Hi & welcome to MrExcel.
Code:
``````Sub ryouko()
Dim Cl As Range
Dim Tmp As Long, i As Long
Dim Dic As Object, Ky As Variant

i = 4
Set Dic = CreateObject("scripting.dictionary")
For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
If Not Dic.Exists(Cl.Value) Then
Else
Tmp = Dic(Cl.Value)(0) + Cl.Offset(, 2).Value
End If
Dic(Cl.Value)(1)(Cl.Offset(, 1).Value) = Empty
Next Cl

For Each Ky In Dic.Keys
i = i + 1
Cells(1, i).Value = "(" & Dic(Ky)(0) & ") " & Ky
Cells(2, i).Resize(Dic(Ky)(1).Count).Value = Application.Transpose(Dic(Ky)(1).Keys)
Next Ky
End Sub``````

Great work! I am not familiar with dictionaries yet, so tried to do this with inefficient double for loops and stuff like that.

There's only one problem - Total count, because For Each Ky In Dic.Keys represents a unique value and doesn't look for duplicates, as done earlier with If Not Dic.Exists(Cl.Value) Then { Dic.Add, so stops counting after first instance found

Oops missed a bit out
Code:
``````Sub ryouko()
Dim Cl As Range
Dim Tmp As Long, i As Long
Dim Dic As Object, Ky As Variant

i = 4
Set Dic = CreateObject("scripting.dictionary")
For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
If Not Dic.Exists(Cl.Value) Then
Else
Tmp = Dic(Cl.Value)(0) + Cl.Offset(, 2).Value
[COLOR=#0000ff] Dic(Cl.Value) = Array(Tmp, Dic(Cl.Value)(1))[/COLOR]
End If
Dic(Cl.Value)(1)(Cl.Offset(, 1).Value) = Empty
Next Cl

For Each Ky In Dic.Keys
i = i + 1
Cells(1, i).Value = "(" & Dic(Ky)(0) & ") " & Ky
Cells(2, i).Resize(Dic(Ky)(1).Count).Value = Application.Transpose(Dic(Ky)(1).Keys)
Next Ky
End Sub``````

Oops missed a bit out
Code:
``````Sub ryouko()
Dim Cl As Range
Dim Tmp As Long, i As Long
Dim Dic As Object, Ky As Variant

i = 4
Set Dic = CreateObject("scripting.dictionary")
For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
If Not Dic.Exists(Cl.Value) Then
Else
Tmp = Dic(Cl.Value)(0) + Cl.Offset(, 2).Value
[COLOR=#0000ff] Dic(Cl.Value) = Array(Tmp, Dic(Cl.Value)(1))[/COLOR]
End If
Dic(Cl.Value)(1)(Cl.Offset(, 1).Value) = Empty
Next Cl

For Each Ky In Dic.Keys
i = i + 1
Cells(1, i).Value = "(" & Dic(Ky)(0) & ") " & Ky
Cells(2, i).Resize(Dic(Ky)(1).Count).Value = Application.Transpose(Dic(Ky)(1).Keys)
Next Ky
End Sub``````

Thanks, you are a start !

You're welcome & thanks for the feedback

Replies
0
Views
44
Replies
3
Views
48
Replies
6
Views
104
Replies
2
Views
240
Replies
3
Views
132

1,211,850
Messages
6,104,361
Members
447,902
Latest member
chriswebs23

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back