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 is/are the macro(s) ?

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
Range("H2:I14").ClearContents
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
  Else
    ExtractValue = ExtractValue & " " & c.Offset(0, -5).Value
  End If
End If
Next c
End Function             
              

Interesting Topics