Option Explicit
Sub CombineKeys()
Dim wsIn As Worksheet, wsOut As Worksheet
Dim vIn As Variant, vOut As Variant
Dim lR1 As Long, lR2 As Long, lC1 As Long, lC2 As Long, UBi1 As Long, UBi2 As Long, UBo1 As Long, UBo2 As Long
Dim colKey As Collection
Set colKey = New Collection
Set wsIn = Sheets("KeyIn") '<<<< adjust sheet name to input sheet
Set wsOut = Sheets("KeyOut") '<<<< adjust sheet name to output sheet
'read the input range into array for fast processing
vIn = wsIn.Range("A1").CurrentRegion.Value
'get array size
UBi1 = UBound(vIn, 1)
UBi2 = UBound(vIn, 2)
'Get the unique keys. Do this by adding into collection.
'When trying to add a key (2nd parameter) to collection, it will _
error if the key already exists. By telling VBA to continue, the _
add wil be aborted and the next item processed
On Error Resume Next
For lR1 = 1 To UBi1
'keys are in 1st column of vIn
colKey.Add vIn(lR1, 1), CStr(vIn(lR1, 1))
Next lR1
On Error GoTo 0 'reset error behaviour to give warning
'make a first guess at the required size of the output array
'divide total nr items by number of keys as average items /key
lC2 = UBi1 * (UBi2 - 1) / colKey.Count
lC2 = lC2 + 1
If lC2 < UBi2 Then lC2 = UBi2
ReDim vOut(1 To colKey.Count, 1 To lC2 + 1)
UBo1 = colKey.Count
UBo2 = lC2 + 1
For lR2 = 1 To colKey.Count
vOut(lR2, 1) = colKey.Item(lR2) 'get key in first column of output
lC2 = 2
For lR1 = 1 To UBi1
If vOut(lR2, 1) = vIn(lR1, 1) Then 'same key, get items on that row
For lC1 = 2 To UBi2
If Len(vIn(lR1, lC1)) Then
'add item to output array
vOut(lR2, lC2) = vIn(lR1, lC1)
' increase column counter of output array
lC2 = lC2 + 1
If lC2 > UBo2 Then
'make the array larger to accept more items under the key
ReDim Preserve vOut(1 To colKey.Count, 1 To lC2 + 5)
UBo2 = UBound(vOut, 2)
End If
Else 'empty, go to next row of input array
Exit For
End If
Next lC1
End If
Next lR1
Next lR2
'dump output array to output sheet
wsOut.Range("A1").Resize(UBo1, UBo2).Value = vOut
Set colKey = Nothing
Set wsIn = Nothing
Set wsOut = Nothing
End Sub
