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

ryouko

New Member
Joined
Feb 8, 2019
Messages
3
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:

I3EbdHi.png
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Hi & welcome to MrExcel.
How about
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
         Dic.Add Cl.Value, Array(Cl.Offset(, 2).Value, CreateObject("scripting.dictionary"))
      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
 
Upvote 0
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
 
Upvote 0
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
         Dic.Add Cl.Value, Array(Cl.Offset(, 2).Value, CreateObject("scripting.dictionary"))
      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
 
Upvote 0
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
         Dic.Add Cl.Value, Array(Cl.Offset(, 2).Value, CreateObject("scripting.dictionary"))
      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 !
 
Upvote 0
You're welcome & thanks for the feedback
 
Upvote 0

Forum statistics

Threads
1,213,524
Messages
6,114,117
Members
448,549
Latest member
brianhfield

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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Back
Top