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

Question

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

一个这样的细胞的例子：

Ciencias delaEducación，Educación，Pedagogía，Ciencias delaEducación，Educación，Pedagogía

应该看起来像：

Ciencias delaEducació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

添加对库的引用后：转到工具 - >参考并选择“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

<强>截图