List the Unique and Concatenated Corresponding Values
Before the macro...
After the macro...
The following procedure uses the Dictionary object to list in Column D the unique values from Column A, and list in Column E their concatenated corresponding values from Column B. Note that the Dictionary object is a component of the Microsoft Scripting library, which requires Excel 2000 or later. Also, you'll need to set a reference to Microsoft Scripting Runtime by using Tools > References in the Visual Basic Editor (Alt+F11).
'Force the explicit
declaration of variables
Option Explicit
Sub
ListUniqueValues()
'Set a reference to Microsoft
Scripting Runtime by using
'Tools > References in
the Visual Basic Editor (Alt+F11)
'Declare the variables
Dim oDict As Dictionary
Dim sData() As Variant
Dim LastRow As Long
Dim i As Long
Dim Cnt As Long
'Create an instance of the
Dictionary object
Set oDict =
CreateObject("Scripting.Dictionary")
'Find the last used row
LastRow = Cells(Rows.Count,
"A").End(xlUp).Row
'Loop through the data and
fill an array with unique
'and concatenated
corresponding values
For i = 2 To LastRow
If Not
oDict.Exists(Cells(i, "A").Value) Then
Cnt
= Cnt + 1
ReDim Preserve sData(1
To 2, 1 To Cnt)
sData(1,
Cnt) = Cells(i, "A").Value
sData(2,
Cnt) = Cells(i, "B").Value
oDict.Add
Cells(i, "A").Value, Cnt
Else
sData(2,
oDict.Item(Cells(i, "A").Value)) = _
sData(2,
oDict.Item(Cells(i, "A").Value)) & _
",
" & Cells(i, "B").Value
End If
Next i
'Insert the column headers
for Columns D and E
Range("D1").Value =
Range("A1").Value
Range("E1").Value =
Range("B1").Value
'Transfer the contents of the
array to a worksheet range, starting at D2
Range("D2").Resize(UBound(sData,
2), 2).Value = _
WorksheetFunction.Transpose(sData)
End Sub
Where to Put the Code
- Open the workbook in which to store the code.
- Open the Visual Basic Editor (Alt+F11).
- Insert a standard module (Insert > Module).
- Copy/paste the above code into the module.
- Return to Microsoft Excel (Alt+Q).
- Save the workbook.
How to Use the Macro
- Display the Macro dialog box (Alt+F8).
- Click/select the macro called "ListUniqueValues".
- Click/select "Run".
Sample Workbook: Download