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
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
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
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,562
Messages
6,114,326
Members
448,564
Latest member
ED38

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