Concatenate Cell Value Data dictionary array

MICKEYSIX

New Member
Joined
Sep 24, 2011
Messages
11
I found a nice piece of code at:


XL-CENTRAL.COM : VBA : List the Unique and Concatenated Corresponding Values


but with the data set I am using it gives me a type missmatch 13 all indicateion is that it crash because of the max element limits of transpose function.


I would like to reduce the transpose requirement only adding to the data dictionary one unique value at a time via a specific cell reference or other method.

any assistance in setting it up would be appreciated......

Here is the code


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
 

Some videos you may like

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

Jerry Sullivan

MrExcel MVP
Joined
Mar 18, 2010
Messages
8,787
A quick fix would be to have your code transpose the array instead of using WorksheetFunction.Transpose

Modifying the bottom of the code to something like this...
Code:
 'Transfer the contents of the array to a worksheet range, starting at D2
 Dim sResults() As Variant
 Dim iR As Long, iC As Long

 ReDim sResults(1 To UBound(sData, 2), 1 To 2)
 For iC = 1 To 2
   For iR = 1 To UBound(sResults, 1)
      sResults(iR, iC) = sData(iC, iR)
   Next iR
 Next iC
  
 Range("D2").Resize(UBound(sData, 2), 2).Value = sResults


Since you're working with a large dataset, there's some changes that could reduce the execution time:

1. Read the entire dataset into an array initially to reduce the number of reads from the worksheet.

2. Eliminate the Redim Preserve step by sizing the array for the maximum case (or reduce the number of Redim Preserve calls by doing that for increments of 10,000 elements)

Code:
Sub ListUniqueValuesForLargeDatasets()
 '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 sInput() 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
 If LastRow < 2 Then Exit Sub
 
 sInput = Range("A1:B" & CStr(LastRow))
 
 'Size array for max case of no duplicates
 ReDim sData(1 To LastRow, 1 To 2)
 
 'Loop through the data and fill an array with unique
 'and concatenated corresponding values
 For i = 2 To UBound(sInput, 1)
   If Not oDict.Exists(sInput(i, 1)) Then
     Cnt = Cnt + 1
     sData(Cnt, 1) = sInput(i, 1)
     sData(Cnt, 2) = sInput(i, 2)
     oDict.Add CStr(sInput(i, 1)), Cnt
   Else
     sData(oDict.Item(sInput(i, 1)), 2) = _
     sData(oDict.Item(sInput(i, 1)), 2) & _
        ", " & sInput(i, 2)
   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(Cnt, 2).Value = sData

 End Sub
 

MICKEYSIX

New Member
Joined
Sep 24, 2011
Messages
11
Jerry,

Thanks Much!!! Sorry to report I took the easy way out and used your first recommendation..work like a champ!! I will play with the other once I fully understand the loops...starting late in life working with VBA "Slow and Old" learner.
Thanks Again! Rusty
 

Watch MrExcel Video

Forum statistics

Threads
1,127,104
Messages
5,622,746
Members
415,925
Latest member
Ryle23

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
Top