List unique values then combine in one single cell all data using a macro in an excel report

In one of my reports, I have to list from a column the unique values then once done, I need to extract from another column all values into one single cell corresponding to each unique value.

macro excel macro excel

When I use the macro ?

To create a list of unique data then extract all data from another column.


How to create the macro ?

Read How to create, edit, hide and select a macro in an excel report


How to create the button to associate it with the macro ?

Read How to create a button and associated it to a macro in an excel report


How are the macros ?

Copy the code below and paste it into your macro. You will see my comments in green if exist so follow the help to adapt to your need.

Sub test()
' change H2:I14 by your range to clear unique list and extracted value
Dim x As Range
With CreateObject("scripting.dictionary")
.CompareMode = 1
' change F2 and F by the column cell where to identity unique list
For Each x In Range("F2", Range("F" & Rows.Count).End(xlUp))
If Not x.Value = "" Then .Item(x.Value) = Empty
Next x
' change H2 by the column cell where to put the unique list
Range("H2").Resize(.Count, 1).Value = Application.Transpose(Array(.Keys, .Items))
End With
With ActiveSheet
' change H2 and $F$2:$F$14 by your new cells
' change I2 by the column cell where to put this formula to extract value
If .Range("H2").Value > 0 Then _
.Range("I2").Value = "=IF(H2="""","""",ExtractValue($F$2:$F$14,H2))"
End With
' optional line below, sort number by high to small, if want contrary, change xlDescending by xlAscending
' change H2 and H14 by your range
Range("H2:H14").Sort Key1:=Range("H2"), Order1:=xlDescending
' change I2 and I3:I14 by the range to copy/paste the formula
Range("I2").Copy Range("I3:I14")
End Sub

' to create the formula to extract value, not needed if use TEXTJOIN formula
Function ExtractValue(r As Range, v As Variant)
Dim c As Range
ExtractValue = ""
For Each c In r
If c.Value = v Then
If ExtractValue = "" Then
' change -5 counting from the identified unique list column to the extract value column
' i.e. my identified unique list column F and the extract value column A = -5
ExtractValue = c.Offset(0, -5).Value
ExtractValue = ExtractValue & " " & c.Offset(0, -5).Value
End If
End If
Next c
End Function

Interesting Management