merge cells (on a Excell sheet) of selected columns , and only the duplicated values with the sign ; in between the merged cells!

Sub kTest()
    
    Dim FC, MC, i As Long, Colors, x, n As Long, c As Long
    Dim dic As Object, MergeCol As Range, j As Long, MRC, MRA As String
    
    Colors = Array(0, 16711680, 5287936, 13369446, 49407) '<< add more colors
    
    Const FirstCol = "B"    '<< adjust to suit
    Const MyRangeAddress = "A:F"   '<< adjust to suit
    
    Set MergeCol = Application.InputBox("Select the Range to be MERGED", Type:=8)
    
    With MergeCol
        MRA = .Parent.Range(CStr(Split(MyRangeAddress, ":")(0) & .Row & ":" & _
                        Split(MyRangeAddress, ":")(1) & .Row + .Rows.Count - 1)).Address
        MRC = .Parent.Range(MRA).Value2
        FC = .Parent.Range(FirstCol & .Row).Resize(.Rows.Count).Value2
    End With
    
    MC = MergeCol.Value2
    
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    
    For i = UBound(FC, 1) To 1 Step -1
        If Len(FC(i, 1)) Then
            If Not dic.exists(FC(i, 1)) Then
                dic.Item(FC(i, 1)) = i
            Else
                j = dic.Item(FC(i, 1))
                For c = 1 To UBound(MRC, 2)
                    MRC(j, c) = Empty
                Next
                MC(i, 1) = MC(i, 1) & ";" & MC(j, 1)
                MC(j, 1) = Empty
                dic.Item(FC(i, 1)) = i
            End If
        End If
    Next
    
    MergeCol.Parent.Range(MRA) = MRC
    
    With MergeCol
        .Value = MC
        For i = 1 To UBound(MC, 1)
            If InStr(1, MC(i, 1), ";") Then
                x = Split(MC(i, 1), ";")
                With .Cells(i, 1)
                    n = 1: c = 0
                    For j = 0 To UBound(x)
                        If j > UBound(Colors) Then c = 0
                        .Characters(n, Len(x(j))).Font.Color = Colors(c)
                        .Characters(Len(x(j)) + n, 1).Font.Color = 255
                        n = n + Len(x(j)) + 1
                        c = c + 1
                    Next
                    .Font.Size = 12
                    .Font.Bold = True
                    .Interior.Color = vbYellow
                End With
            End If
        Next
    End With
    
End Sub

Select all Open in new window