Concatenate cells if same value - some issues with the code (sample sheet)

Hi everyone!

I'm new here but it's amazing how helpful everybody seems to be. I have this issue with my code that I would really appreciate some help on.

There are three main issues with the code:

1. The blank spaces needs to remain
2. If the product is the same, no need to combine them
3. Instead of , use &

It's probably easier to look at the sample sheet rather than me trying to explain it. I have also written more detailed in the sample sheet.

Thank you in advance :)

The code is below:

Sub ConcatenateCellsIfSameValues()
Dim xCol As New Collection
Dim xSrc As Variant
Dim xRes() As Variant
Dim I As Long
Dim J As Long
Dim xRg As Range


xSrc = Range("F1", Cells(Rows.Count, "F").End(xlUp)).Resize(, 2)
Set xRg = Range("Q3")
On Error Resume Next
For I = 2 To UBound(xSrc)
xCol.Add xSrc(I, 1), TypeName(xSrc(I, 1)) & CStr(xSrc(I, 1))
Next I
On Error GoTo 0
ReDim xRes(1 To xCol.Count + 1, 1 To 2)
xRes(1, 1) = "Customer"
xRes(1, 2) = "Combined product"
For I = 1 To xCol.Count
xRes(I + 1, 1) = xCol(I)
For J = 2 To UBound(xSrc)
If xSrc(J, 1) = xRes(I + 1, 1) Then
xRes(I + 1, 2) = xRes(I + 1, 2) & ", " & xSrc(J, 2)
End If
Next J
xRes(I + 1, 2) = Mid(xRes(I + 1, 2), 2)
Next I
Set xRg = xRg.Resize(UBound(xRes, 1), UBound(xRes, 2))
xRg.NumberFormat = "@"
xRg = xRes


End Sub

Attached Files

• Sample.xlsm‎ (19.6 KB) Download