Concatenate Cell Value Data dictionary array

[MICKEYSIX]

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

 

[Jerry Sullivan]

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...

 '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)

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]

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