VBA EXCEL concatenating values from a column based on duplicates in other columns

Question

I'm new to vba Excel and I need to solve a problem with a macro. I have modified some of the proposed macros here, but I can't achieve what I need.

I would like to concatenate values ​​from column A based on duplicates in column B, then column C, etc. The results should be below each of the examined columns. It would be nice to concatenate all the same values ​​together without a space and separate the next group of duplicate values ​​with a ".". But if this is not possible, putting the repeated value in different cells of the same column will also be fine. I'm sure my explanation isn't good enough, so here's an example:

Col A	Col B	Col C	etc
A	blue	green
B	red	blue
C	blue	blue
D	red	red
E	green	red
	AC.BD.E	A.BC.DE

Is it possible?

I copy here what I have tried untill now. I have just change the code found in the link from above. I'm sure it can be easier. I don't really need that it ask where to put the output if the print the result as I have asked. Also, I don't need 2 columns, just 1 and without the header.

Sub ConcatenateCellsIfSameValues()
Dim xCol As New Collection
Dim xSrc As Variant
Dim xSrcValue As Variant
Dim xRes() As Variant
Dim i As Long
Dim J As Long
Dim xRg As Range
Dim xResultAddress As String
Dim xMergeAddress As String
Dim xUp As Variant

'xResultAddress = "C24" 'The cell to output the results
xMergeAddress = "A" 'The column you will combine based on the duplicates in column A

xSrc = Range("D1", Cells(Rows.count, "D").End(xlUp)).Resize(, 1)
xUp = Range("D1", Cells(Rows.count, "D").End(xlUp)).Rows.count
xSrcValue = Range(xMergeAddress & "1:" & xMergeAddress & xUp)

If ActiveWindow.RangeSelection.count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("Selecciona celda output", "Output", , , , , , 8)
If xRg Is Nothing Then Exit Sub
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) = "No" - Not needed
'xRes(1, 2) = "Combined Color" - Not needed
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) & vbCr & xSrcValue(J, 1)
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
xRg.EntireColumn.AutoFit
End Sub

Thank you in advance!

Answer 1

Concat Matches (UDF)

Function ConcatMatches( _
    ByVal ConcatRange As Range, _
    ByVal MatchRange As Range, _
    Optional ByVal OuterDelimiter As String = ".", _
    Optional ByVal InnerDelimiter As String = "", _
    Optional ByVal MatchCase As Boolean = False) _
As String

    Dim rCount As Long: rCount = ConcatRange.Rows.Count
    Dim cCount As Long: cCount = ConcatRange.Columns.Count
    
    Dim nCount As Long, rStr As String, IsRow As Boolean
    
    If rCount = 1 Then
        If cCount = 1 Then
            rStr = CStr(ConcatRange.Value): GoTo WriteResult
        Else ' cCount > 1
            IsRow = True
            nCount = cCount
        End If
    Else ' rCount > 1
        cCount = 1
        nCount = rCount
    End If
    
    Dim cData(): cData = ConcatRange.Cells(1).Resize(rCount, cCount).Value
    Dim mData(): mData = MatchRange.Cells(1).Resize(rCount, cCount).Value
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    If Not MatchCase Then dict.CompareMode = vbTextCompare
    
    Dim cVal As String, mVal As String, n As Long
    
    For n = 1 To nCount
        If IsRow Then
            cVal = CStr(cData(1, n)): mVal = CStr(mData(1, n))
        Else
            cVal = CStr(cData(n, 1)): mVal = CStr(mData(n, 1))
        End If
        
        If Len(cVal) > 0 Then
            If dict.Exists(mVal) Then
                dict(mVal) = dict(mVal) & InnerDelimiter & cVal
            Else
                dict(mVal) = cVal
            End If
        End If
    Next n
    
    If dict.Count > 0 Then rStr = Join(dict.Items, OuterDelimiter)
    
WriteResult:
    
    ConcatMatches = rStr

End Function

Answer 2

Public Sub easySolution()
Dim rowMax As Integer
Dim colMax As Integer
Dim matrix() As Variant
Dim rng As Range
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim val As Variant

rowMax = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
colMax = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column

'assuming that you range start at 1,1
Set rng = Worksheets("Sheet1").Range(Worksheets("Sheet1").Cells(1, 1), Worksheets("Sheet1").Cells(rowMax, colMax))

matrix = rng

For j = LBound(matrix, 2) + 1 To UBound(matrix, 2)
    
    For i = LBound(matrix, 1) To UBound(matrix, 1)
        If matrix(i, j) <> "check" Then
            'set the first available value to compare
            val = matrix(i, j)
            
            If i = 1 Then
                Worksheets("Sheet1").Cells(rowMax + 1, j).Value = Worksheets("Sheet1").Cells(rowMax + 1, j).Value & " " & matrix(i, 1)
            Else
                Worksheets("Sheet1").Cells(rowMax + 1, j).Value = Worksheets("Sheet1").Cells(rowMax + 1, j).Value & "." & matrix(i, 1)
            End If
    
            matrix(i, j) = "check"
        End If
        
        'check for dup
            For k = i + 1 To UBound(matrix, 1)
                    If matrix(k, j) = val Then
                        Worksheets("Sheet1").Cells(rowMax + 1, j).Value = Worksheets("Sheet1").Cells(rowMax + 1, j).Value & " " & matrix(k, 1)
                        matrix(k, j) = "check"
                    End If
            Next k
    Next i
Next j

End Sub