Macro to remove duplicate values when some cells contain multiple values

[jmk1153]

Hello,

I am having trouble creating a macro that will take the color information below and consolidate it into one cell having removed duplicate colors. The problem I'm running into is that some cells contain multiple colors. If I use the remove duplicate logic built into excel, it will consider the entire cell, not the colors separated by the semicolon.

i.e. The final product would be a single cell that lists all colors concatenated together separated by a semicolon.

Cells A1:A7

red, light; blue; dark, green; light

red light; green, light

maroon light; red light

yellow, dark; brown, dark

orange, light

yellow, dark; brown, dark

orange, light

Result in A8: red, light; blue; dark, green; light; maroon, light; yellow, dark; brown, dark; orange, light

Is this possible? I have attempted to put something together but this is a little over my head. I'm definitely stuck.

 

[lrobbo314]

How about this.

Function GETUNIQUE(r As Range) As String
Dim AR() As Variant: AR = r.Value
Dim SP() As String

With CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(AR)
        SP = Split(AR(i, 1), ", ")
        For j = 0 To UBound(SP) - 1
            If Not .contains(SP(j)) Then .Add SP(j)
        Next j
    Next i
    GETUNIQUE = Join(.toarray, ", ")
End With
End Function

Then in A8 your formula would be - =GETUNIQUE(A1:A7)

 

[jmk1153]

Thank you very much. That works perfectly.

Appreciate the help!

 

[lrobbo314]

───────────────────░█▓▓▓█░▇▆▅▄▃▂
──────────────────░█▓▓▓▓▓█░▇▆▅▄▃▂
─────────────────░█▓▓▓▓▓█░▇▆▅▄▃▂
──────────░░░───░█▓▓▓▓▓▓█░▇▆▅▄▃▂
─────────░███░──░█▓▓▓▓▓█░▇▆▅▄▃▂
───────░██░░░██░█▓▓▓▓▓█░▇▆▅▄▃▂
──────░█░░█░░░░██▓▓▓▓▓█░▇▆▅▄▃▂
────░██░░█░░░░░░█▓▓▓▓█░▇▆▅▄▃▂
───░█░░░█░░░░░░░██▓▓▓█░▇▆▅▄▃▂
──░█░░░░█░░░░░░░░█▓▓▓█░▇▆▅▄▃▂
──░█░░░░░█░░░░░░░░█▓▓▓█░▇▆▅▄▃▂
──░█░░█░░░█░░░░░░░░█▓▓█░▇▆▅▄▃▂
─░█░░░█░░░░██░░░░░░█▓▓█░▇▆▅▄▃▂
─░█░░░░█░░░░░██░░░█▓▓▓█░▇▆▅▄▃▂
─░█░█░░░█░░░░░░███▓▓▓▓█░▇▆▅▄▃▂
░█░░░█░░░██░░░░░█▓▓▓▓▓█░▇▆▅▄▃▂
░█░░░░█░░░░█████▓▓▓▓▓█░▇▆▅▄▃▂
░█░░░░░█░░░░░░░█▓▓▓▓▓█░▇▆▅▄▃▂
░█░█░░░░██░░░░█▓▓▓▓▓█░▇▆▅▄▃▂
─░█░█░░░░░████▓▓▓▓██░▇▆▅▄▃▂
─░█░░█░░░░░░░█▓▓██▓█░▇▆▅▄▃▂
──░█░░██░░░██▓▓█▓▓▓█░▇▆▅▄▃▂
───░██░░███▓▓██▓█▓▓█░▇▆▅▄▃▂
────░██▓▓▓███▓▓▓█▓▓▓█░▇▆▅▄▃▂
──────░█▓▓▓▓▓▓▓▓█▓▓▓█░▇▆▅▄▃▂
──────░█▓▓▓▓▓▓▓▓▓▓▓▓▓█░▇▆▅▄▃▂

 

[jmk1153]

At first glance I thought it was working properly but it seems to be a little off now that I've gone through it again. It starts pulling the correct data but when it moves onto the next line it gets confused.

The example I gave may have been a little confusing. The true unique values are separated by the semicolon only. It seems like the comma is causing the confusion but unfortunately that isn't something I can remove as it would cause confusion during the next step.

red, light; blue, dark; green, light;

red, light; green, light;

maroon, light; red, light;

yellow, dark; brown, dark;

orange, light;

yellow, dark; brown, dark;

orange, light;

Expected:
red, light; blue, dark; green, light; maroon, light; yellow, dark; brown, dark; orange, light

Actual:
red, light; blue, dark; green, light; green, maroon, light; red, yellow, dark; brown, orange

 

[Fluff]

How about

Function JMK(Rng As Range) As String
    Dim Cl As Range
    Dim Sp As Variant
    Dim i As Long
    
    With CreateObject("scripting.dictionary")
        For Each Cl In Rng
            Sp = Split(Cl, ";")
            For i = 0 To UBound(Sp)
                .Item(Trim(Sp(i))) = Empty
            Next i
        Next Cl
        JMK = Join(.keys, "; ")
    End With
End Function

 

[Fluff]

Previous code will output a blank value, use this instead.

Function JMK(Rng As Range) As String
    Dim Cl As Range
    Dim Sp As Variant
    Dim i As Long
    
    With CreateObject("scripting.dictionary")
        For Each Cl In Rng
            Sp = Split(Cl, ";")
            For i = 0 To UBound(Sp)
                If Sp(i) <> "" Then .Item(Trim(Sp(i))) = Empty
            Next i
        Next Cl
        JMK = Join(.keys, "; ")
    End With
End Function