How to remove duplicate values from 2 columns in excel using vba

Question

I am new to Excel VBA Programming. I have one excel sheet with two columns and each column has some email adresses separated by @@. like
ColumA
aa@yahoo.com@@bb@yahoo.com@@cc@yahoo.com
x@.com@@y@y.com

ColumnB
zz@yahoo.com@@aa@yahoo.com
aa@yahoo.com

As you can see that both column has two rows, I need 3rd column that should contain all the unique values like
ColumnC
aa@yahoo.com@@bb@yahoo.com@@cc@yahoo.com@zz@yahoo.com
x@.com@@y@y.com@@aa@yahoo.com

Thanks

Answer 1

Something like this with variant arrays and a dictionary is an efficient process of getting your desired outcome

[updated to remove delimiter at front of string, code is flexible on delimiter length] SO seems to have removed the ability to upload image so my picture has fallen off ....

Sub GetUniques()
Dim strDelim As String
Dim X
Dim Y
Dim objDic As Object
Dim lngRow As Long
Dim lngRow2 As Long
strDelim = "@@"
Set objDic = CreateObject("scripting.dictionary")
X = Range([a1], Cells(Rows.Count, "B").End(xlUp)).Value2
For lngRow = 1 To UBound(X, 1)
    X(lngRow, 1) = X(lngRow, 1) & strDelim & X(lngRow, 2)
    Y = Split(X(lngRow, 1), strDelim)
    X(lngRow, 1) = vbNullString
    For lngRow2 = 0 To UBound(Y, 1)
        If Not objDic.exists(lngRow & Y(lngRow2)) Then
            X(lngRow, 1) = X(lngRow, 1) & (strDelim & Y(lngRow2))
            objDic.Add (lngRow & Y(lngRow2)), 1
        End If
    Next lngRow2
    If Len(X(lngRow, 1)) > Len(strDelim) Then X(lngRow, 1) = Right(X(lngRow, 1), Len(X(lngRow, 1)) - Len(strDelim))
Next lngRow
[c1].Resize(UBound(X, 1), 1).Value2 = X
End Sub

Answer 2

Here's my take. How it works:

1. Dump columnA and B into a variant array
2. Combine each row, split into an array of emails, then weed out dupes with a dictionary.
3. Combine unique list into a single string and store in a new array
4. Transpose the new array onto column C.

Sub JoinAndUnique()

Application.ScreenUpdating = False
Dim varray As Variant, newArray As Variant
Dim i As Long, lastRow As Long
Dim temp As Variant, email As Variant
Dim newString As String, seperator As String
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")

seperator = "@@"
lastRow = range("A" & Rows.count).End(xlUp).Row
varray = range("A1:B" & lastRow).Value
ReDim newArray(1 To UBound(varray, 1))

On Error Resume Next
For i = 1 To UBound(varray, 1)
    temp = Split(varray(i, 1) & seperator & varray(i, 2), seperator)
    For Each email In temp
        If Not dict.exists(email) Then
            dict.Add email, 1
            newString = newString & (seperator & email)
        End If
    Next
    newArray(i) = Mid$(newString, 3)
    dict.RemoveAll
    newString = vbNullString
Next

range("C1").Resize(UBound(newArray)).Value = Application.Transpose(newArray)
Application.ScreenUpdating = True

End Sub

Note: It's fairly similar to brettdj's answer, but there are a few differences worth mentioning:

• I used more meaninful names for variables (for readability and to make it easier to edit)
• I do clean up of the "@@" at the start of the sentence
• I use a new array rather than overwrite the values of an existing one
• I choose to clear the dictionary after each cell
• I choose to use "on error resume next" and just dump entries into the dictionary instead of checking if they exist or not (personal preference, makes no major difference)

Answer 3

The easiest way to do this would be to use the dictionary object, split function, and join function. Of course, you don't need to use those exact ones, but give it a try and see what you get.