如何删除excel中单元格内用逗号分隔的重复项？

Question

我处理了一个非常长的 Excel 文件（最多 11000 行和 7 列），其中一个单元格中有许多重复的数据。我正在寻找一个宏来摆脱它，但找不到。

一个这样的细胞的例子：

Ciencias de la Educación,Educación,Pedagogía,Ciencias de la Educación,Educación,Pedagogía

应该是这样的：

Ciencias de la Educación,Educación,Pedagogía

我怎样才能摆脱成千上万的重复（更不用说额外的、孤立的、逗号）？

Answer 1

这段代码在我的机器上运行了 6 秒，在@SiddharthRout 的机器上运行了 2 秒:) （单元格A1:G20000 中的数据：20000x7=140000 个非空单元格）

Sub test2()
    Dim c, arr, el, data, it
    Dim start As Date
    Dim targetRange As Range

    Dim dict As Object
    Set dict = CreateObject("Scripting.dictionary")

    Application.ScreenUpdating = False

    Set targetRange = Range("A1:G20000")

    data = targetRange

    start = Now
    For i = LBound(data) To UBound(data)
        For j = LBound(data, 2) To UBound(data, 2)
            c = data(i, j)
            dict.RemoveAll
            arr = Split(c, ",")
            For Each el In arr
                On Error Resume Next
                dict.Add Trim(el), Trim(el)
                On Error GoTo 0
            Next
            c = ""
            For Each it In dict.Items
               c = c & it & ","
            Next
            If c <> "" Then c = Left(c, Len(c) - 1)
            data(i, j) = c
        Next j
    Next i
    targetRange = data
    Application.ScreenUpdating = True

    MsgBox "Working time: " & Format(Now - start, "hh:nn:ss")

End Sub

---

您可以通过更改接下来的两行来使这段代码稍微快一点

Dim dict As Object
Set dict = CreateObject("Scripting.dictionary")

到

Dim dict As new Dictionary

添加库引用后：转到Tools->References并选择“Microsoft Scripting Runtime”

Answer 2

这是一个基本的例子

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

    sString = "Ciencias de la Educación,Educación,Pedagogía,Ciencias de la Educación,Educación,Pedagogía"

    MyAr = Split(sString, ",")

    For i = LBound(MyAr) To UBound(MyAr)
        On Error Resume Next
        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)

    Debug.Print sString
End Sub

编辑

在 Excel 2010 中使用A1:G20000 填充Ciencias de la Educación,Educación,Pedagogía,Ciencias de la Educación,Educación,Pedagogía 进行了尝试和测试

耗时：2 秒

代码

Sub Sample()
    Dim sString As String
    Dim MyAr As Variant, rngAr
    Dim Col As New Collection
    Dim itm
    Dim rng As Range

    Debug.Print "StartTime: " & Now

    Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:G20000")
    rngAr = rng.Value

    For i = LBound(rngAr) To UBound(rngAr)
        For j = LBound(rngAr, 2) To UBound(rngAr, 2)
            MyAr = Split(rngAr(i, j), ",")

            For k = LBound(MyAr) To UBound(MyAr)
                On Error Resume Next
                Col.Add Trim(MyAr(k)), CStr(Trim(MyAr(k)))
                On Error GoTo 0
            Next k

            sString = ""

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

            sString = Mid(sString, 2)

            rngAr(i, j) = sString
        Next j
    Next i

    ThisWorkbook.Sheets("Sheet1").Range("A1").Resize(20000, 7).Value = rngAr

    Debug.Print "EndTime: " & Now
End Sub

屏幕截图