Macro to remove duplicate values from an excel cell

Question

I have duplicate email ids in an excel cell. (Each cell has around 5 to 6 emails which are repeated as below). Is there a macro to remove unique ones from the cell ? I have given an example below for reference, appreciate your assistance.

Cell 1
abc@cc.com
cde@bb.com
abc@cc.com
lmn@nn.com
cde@bb.com

Cell 2
jjj@cc.com
kk@dd.com
jjj@cc.com

Thanks
Auro

tospig · Answer 1 · 2014-12-02T09:11:02.370

I used your data in a blank worksheet in Column A, and the output gets put in Column B. You can change the loops and cell references to suit your needs. I've also assumed you want the email addresses that were contained in a cell to remain grouped (once the duplicates have been removed) in the output.

This code also assumes the email addresses are separated by a 'carriage return'

Sub removeDuplicate()

    'references: http://stackoverflow.com/questions/3017852/vba-get-unique-values-from-array

    Dim wks As Worksheet
    Dim rng As Range
    Dim wordCount As Integer
    Dim d As Object
    Dim i As Integer
    Dim j As Integer
    Dim v As Variant
    Dim outText As String

    Set wks = Worksheets("Sheet1") '<- change sheet to suit needs

    For j = 1 To 2 '<- change loop to suit needs

        Set rng = wks.Range(Cells(j, 1), Cells(j, 1)) '<- change cell reference as required

        Set d = CreateObject("Scripting.Dictionary")
        'use carriage return (chr(10)) as the 'find' text

        'Count Words/email addresses
        wordCount = Len(rng) - Len(Replace(rng, Chr(10), "")) + 1

        'split words by carriage return
        arrWords = Split(rng, Chr(10))

        For i = 0 To wordCount - 1
            d(arrWords(i)) = 1
        Next i

        'create output text by re-grouping the split text. 
        outText = ""
        For Each v In d.keys
            If outText = "" Then
                outText = v
            Else
                outText = outText & Chr(10) + v
            End If
        Next v

        'output to adjacent cell
        rng.Offset(0, 1).Value = outText
        Set d = Nothing
    Next j

    Set wks = Nothing

End Sub

Macro to remove duplicate values from an excel cell

1 Answers1