Question

我在Excel单元格中有重复的电子邮件ID。（每个单元格有大约5到6封电子邮件，重复如下）。是否有宏从单元格中删除唯一的宏？我在下面举了一个例子供参考，感谢您的帮助。

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

Answer 1

我在A列的空白工作表中使用了您的数据，输出放在B列中。您可以更改循环和单元格引用以满足您的需要。我还假设您希望单元格中包含的电子邮件地址在输出中保持分组（一旦删除了重复项）。

此代码还假定电子邮件地址由“回车”

分隔

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

用于从Excel单元格中删除重复值的宏

1 个答案: