loop cells to add multiple items to dictionary keys - excel

Question

I have a list of duplicate values in column A that will be added as keys to a dictionary. Then for each row in column A there are other duplicates values from column 3 to .columns.count. I need to add them to the dictionary as multiples items of each key. At the end I should have two columns: the first listing all the keys and the second all the items of each keys.
Here my tentative. Could you help find out how to fix it?
Sheets("Sheet3").Select
With Sheets("Sheet3")
lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
LR = .Range("A" & Sheets("Competitor").Rows.Count).End(xlUp).row
For thisRow = 2 To LR
For thiscol = 2 To lc
'Debug.Print dict.Keys(0)
If Not dict.Exists(.Cells(thisRow, 1).Value2) And .Cells(thisRow, thiscol).Value2 <> "" Then
dict.Add .Cells(thisRow, 1).Value2, (.Cells(thisRow, thiscol).Value2)
Else
If dict.Exists(.Cells(thisRow, 1).Value2) And .Cells(thisRow, thiscol).Value2 <> "" Then
dict.Item(.Cells(thisRow, 1).Value2) = .Cells(thisRow, thiscol).Value2
End If
End If
Next thiscol
Next thisRow

Answer 1

this uses a Dictionary of dictionaries to return unique items for uniqe keys
Option Explicit
Sub main()
Dim iKey As Long
Dim valsDict As Scripting.Dictionary
Set valsDict = CreateObject("Scripting.Dictionary")
Dim cell As Range, cell2 As Range
With ActiveWorkbook.Sheets("Competitor") ' change "Competitor" to you actual source sheet name
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
If Not valsDict.Exists(cell.value) Then valsDict.Add cell.value, New Scripting.Dictionary
For Each cell2 In .Range(cell.Offset(, 1), .Cells(cell.Row, .Columns.Count).End(xlToLeft))
valsDict(cell.value)(cell2.value) = cell2.value
Next
Next
With .Range("AA1") ' change "AA1" with the cell address you want to start writing down data from
For iKey = 0 To valsDict.Count - 1
.Offset(iKey).value = valsDict.Keys(iKey)
.Offset(iKey, 1).Resize(, valsDict.Items(iKey).Count) = valsDict.Items(iKey).Items
Next
End With
End With
End Sub

Answer 2

You mentioned that you'd want the resulting list in two columns. The following code will create a unique list of values from Column A, along with their corresponding values. The unique values will be listed in one column, and the corresponding values will be concatenated in the next column. Note that I've assumed that the Sheet1 contains the data, and that the results are to be placed in Sheet2.
Option Explicit
Sub CreateUniqueList()
Dim oDic As Object
Dim aResults() As Variant
Dim arrColIndex As Long
Dim LastRow As Long
Dim LastCol As Long
Dim thisRow As Long
Dim thisCol As Long
Set oDic = CreateObject("Scripting.Dictionary")
oDic.CompareMode = 1 'case-insensitive
With ActiveWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
ReDim aResults(1 To 2, 1 To LastRow)
arrColIndex = 0
For thisRow = 2 To LastRow
If Len(.Cells(thisRow, "A").Value) > 0 Then
If Not oDic.Exists(.Cells(thisRow, "A").Value) Then
arrColIndex = arrColIndex + 1
aResults(1, arrColIndex) = .Cells(thisRow, "A").Value
For thisCol = 2 To LastCol
aResults(2, arrColIndex) = aResults(2, arrColIndex) & ", " & .Cells(thisRow, thisCol).Value
Next thisCol
aResults(2, arrColIndex) = Mid(aResults(2, arrColIndex), 3)
oDic.Add .Cells(thisRow, "A").Value, arrColIndex
Else
For thisCol = 2 To LastCol
aResults(2, oDic(.Cells(thisRow, "A").Value)) = aResults(2, oDic(.Cells(thisRow, "A").Value)) & ", " & .Cells(thisRow, thisCol).Value
Next thisCol
End If
End If
Next thisRow
End With
If arrColIndex > 0 Then
ReDim Preserve aResults(1 To 2, 1 To arrColIndex)
With ActiveWorkbook.Worksheets("Sheet2")
With .Range("A1")
.CurrentRegion.ClearContents
.Resize(UBound(aResults, 2), 2).Value = Application.Transpose(aResults)
End With
.Activate
End With
Else
MsgBox "No items found!", vbExclamation
End If
Set oDic = Nothing
End Sub
Data
Header1 Header2 Header3 Header4
x 1 2 3
y 4 5 6
z 7 8 9
x 10 20 30
y 40 50 60
z 70 80 90
Results
x 1, 2, 3, 10, 20, 30
y 4, 5, 6, 40, 50, 60
z 7, 8, 9, 70, 80, 90
Hope this helps!