Remove redundant data from cell in excel worksheet

Question

I have data present in two cells in 2 different columns.

Ex.:
ColA: A1 Cell has comma separated values 1,2,3
ColB: B1 Cell has comma separated values ABC,DEF,ABC

Want to implement logic so that it that it should get displayed as,

ColA    ColB
1,3     ABC
2       DEF

Ex2.:
ColA: A1 Cell has comma separated values 1,2,3
ColB: B1 Cell has comma separated values ABC,ABC,ABC

ColA      ColB
1,2,3     ABC

Till Now, I have implemented logic for Column B But, Not able to update col A data while doing this.

Sub RemoveDupData()
    Dim sString As String
    Dim MyAr As Variant
    Dim Col As New Collection
    Dim itm

    sString = "ABC,DEF,ABC,CDR"

    MyAr = Split(sString, ",")

    For i = LBound(MyAr) To UBound(MyAr)
        On Error Resume Next
        '-- A collection cannot have the same key twice so here, we are creating a key using the item that we are adding.
        '-- This will ensure that we will not get duplicates.       
        Col.Add Trim(MyAr(i)), CStr(Trim(MyAr(i)))
        On Error GoTo 0
    Next i

    sString = ""

    For Each itm In Col
        sString = sString & "," & itm
    Next

    sString = Mid(sString, 2)

End Sub

Answer 1

This method is more complex than Jeeped's, but may be more easily adaptable to variations.

I did a row by row type of processing, but, by simply changing how the key is generated, one could de-duplicate the entire data set colB (see comment in the code)

I used a dictionary to ensure non-duplicate keys, and the dictionary item would be a collection of the related colA values.

Sub FixData()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes  As Range
    Dim vSrc As Variant, vRes As Variant
    Dim vA As Variant, vB As Variant
    Dim I As Long, J As Long
    Dim dD As Object, Col As Collection
    Dim sKey As String

Set wsSrc = Worksheets("sheet1")

'Note that depending on how you set these parameters, you will be
'able to write the Results anyplace in the workbook,
'even overlying the original data
Set wsRes = Worksheets("sheet1")
    Set rRes = wsRes.Cells(1, 5)

With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp))
End With

'Use a dictionary to collect both the unique items in ColB (which will be the key)
'and a collection of the relevant objects in ColA
Set dD = CreateObject("scripting.dictionary")
For I = 1 To UBound(vSrc, 1)
    vA = Split(vSrc(I, 1), ",")
    vB = Split(vSrc(I, 2), ",")
        If UBound(vA) <> UBound(vB) Then
            MsgBox "different number of elements in each column"
        End If

        For J = 0 To UBound(vA)
            sKey = vB(J) & "|" & I

            'To remove dups from the entire data set
            ' change above line to:
            'sKey = vB(J)

            If Not dD.Exists(sKey) Then
                Set Col = New Collection
                Col.Add vA(J)
                dD.Add Key:=sKey, Item:=Col
            Else
                dD(sKey).Add vA(J)
            End If
        Next J
Next I

'Create Results array
ReDim vRes(1 To dD.Count, 1 To 2)
I = 0
For Each vB In dD.Keys
    I = I + 1
    vRes(I, 2) = Split(vB, "|")(0)

    For J = 1 To dD(vB).Count
        vRes(I, 1) = vRes(I, 1) & "," & dD(vB)(J)
    Next J
        vRes(I, 1) = Mid(vRes(I, 1), 2) 'remove leading comma
Next vB

'write results to worksheet
Set rRes = rRes.Resize(UBound(vRes, 1), 2)
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .HorizontalAlignment = xlLeft
End With
End Sub

Source Data

Row by Row processing

Entire Data Set processing

Answer 2

This seems to satisfy both of the examples you posted.

Option Explicit

Sub RemoveDupData()
    Dim i As Long, valA As Variant, valB As Variant, r As Variant
    With Worksheets("sheet7")
        valA = Split(.Cells(1, "A"), Chr(44))
        valB = Split(.Cells(1, "B"), Chr(44))

        For i = LBound(valB) To UBound(valB)
            r = Application.Match(valB(i), valB, 0)
            Select Case True
                Case r < i + 1
                    valB(i) = vbNullString
                Case r > 1
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, 2) = _
                        Array(valA(i), valB(i))
                    valA(i) = vbNullString
                    valB(i) = vbNullString
            End Select
        Next i

        valA = Replace(Application.Trim(Join(valA, Chr(32))), Chr(32), Chr(44))
        valB = Replace(Application.Trim(Join(valB, Chr(32))), Chr(32), Chr(44))

        .Cells(1, "A").Resize(1, 2) = Array(valA, valB)
    End With
End Sub

Answer 3

you could use Dictionary object

Option Explicit

Sub RemoveDupData()
    Dim AData As Variant, BData As Variant

    With Range("A1", cells(Rows.Count, 1).End(xlUp))
        AData = Application.Transpose(.Value)
        BData = Application.Transpose(.Offset(, 1).Value)
        .Resize(, 2).ClearContents
    End With

    Dim irow As Long
    For irow = 1 To UBound(AData)
        WriteNoDupes Split(AData(irow), ","), Split(BData(irow), ",")
    Next
    Range("A1:B1").Delete Shift:=xlUp
End Sub

Sub WriteNoDupes(ADatum As Variant, BDatum As Variant)
    Dim iItem As Long, key As Variant
    With CreateObject("scripting.dictionary")
        For iItem = 0 To UBound(ADatum)
            .Item(BDatum(iItem)) = .Item(BDatum(iItem)) & " " & ADatum(iItem)
        Next
        For Each key In .Keys
            cells(Rows.Count, 1).End(xlUp).Offset(1).Value = Replace(Trim(.Item(key)), " ", ",")
            cells(Rows.Count, 2).End(xlUp).Offset(1).Value = key
        Next
    End With
End Sub