excel - 查找具有不同排列的多个重复值

Question

我希望让我的生活更轻松，并编写一个脚本来搜索并突出显示 Excel 中的重复值。

例如，我有 2 行具有复杂值。第一行不是那么重要，因为它只是一个名称，但第二行很重要，在这里我无法弄清楚如何搜索重复项。一件大事是 vale 是相同的，但有时可能会有所不同。

你能帮我吗，虽然我仍然手动搜索它，2小时后我失去了视力和思想:)

Answer 1

你可以利用：

• SortedList对象，创建一个代码Key，它独立于每列“代码”单元格中的“值”出现顺序

• Dictionary对象，收集同一个code Key对应的所有“人”

如下：

Option Explicit

Sub main()
    Dim iRow As Long
    Dim codeKey As Variant, persons As Variant
    Dim codesRng As Range

    Set codesRng = Range("C3", Cells(Rows.count, 3).End(xlUp)) '<--| set the range with all codes

    Normalize codesRng '<--| rewrite codes with only one delimiter

    With CreateObject("Scripting.Dictionary") '<--| instantiate a 'Dictionary' object
        For iRow = 1 To codesRng.Rows.count '<--| loop through 'codesRng' cells
            codeKey = GetKey(codesRng(iRow, 1)) '<--| get its "Key"
            .item(codeKey) = .item(codeKey) & codesRng(iRow, 1).Offset(, -2) & "|" '<--| update current 'codeKey' dictionary item with  the corresponding "person"
        Next

        For Each codeKey In .Keys '<--| loop through dictionary keys
            persons = Split(Left(.item(codeKey), Len(.item(codeKey)) - 1), "|") '<--| get current key array of "persons"
            If UBound(persons) > 0 Then Debug.Print Join(persons, ",") '<--| print them if more than one person
        Next
    End With '<--| release 'Dictionary' object
End Sub

Sub Normalize(rng As Range)
    With rng
        .Replace " ", "", xlPart
        .Replace "+-", "+", xlPart
        .Replace "(", "", xlPart
        .Replace ")", "", xlPart
        .Replace "/", "+", xlPart
        .Replace "+Ax", "Ax", xlPart
        .Replace "+", "|", xlPart
    End With
End Sub

Function GetKey(strng As String) As Variant
    Dim elements As Variant
    Dim j As Long

    elements = Split(strng, "|") '<--| get an array of values out of those found delimited by a pipe ("|") in the string

    With CreateObject("System.Collections.SortedList") '<--| instantiate a 'SortedList' object
        For j = 0 To UBound(elements) '<--| loop through array values
            .item(CStr(elements(j))) = "" '<--| add them to 'SortedList' object
        Next

        For j = 0 To .count - 1 '<--| iterate through 'SortedList' object elements
            elements(j) = .GetKey(j) '<--| write back array values in sorted order
        Next
    End With '<--| release 'SortedList' object

    GetKey = Join(elements, "|") '<--| return the "Key" as a string obtained from the passed one sorted values
End Function

Answer 2

一个可能有助于开始的示例代码

Sub same()

    Dim a$(), i%, i1%, i2%, j%, r$, s As Boolean, w$, k, t$, dict As Object, c$
    Set dict = CreateObject("scripting.dictionary")
    i = 1
    While Cells(i, 3) <> ""
        ' first split string into multiple strings
        j = 0
        r = Cells(i, 3)
        For i1 = 1 To Len(r)
            c = Mid(r, i1, 1)
            Select Case c
            Case "+", "-", "/", "(", ")"
                s = True
            Case Else
                w = w & c
            End Select
            If s = True Or i1 = Len(r) Then
                If w <> "" Then
                    j = j + 1
                    ReDim Preserve a(j)
                    a(j) = w
                    w = ""
                    s = False
                End If
            End If
        Next i1
        ' sort the strings in ascending order
        k = 0
        For i1 = 1 To j - 1
            k = i1
            For i2 = i1 + 1 To j
                If a(i2) < a(k) Then k = i2
            Next i2
            t = a(i1): a(i1) = a(k): a(k) = t
        Next i1
        ' detect if doublons using a dictionary
        k = Join(a, "-")
        If dict.exists(k) Then 'doublon detected
            Cells(i, 4) = dict.Item(k)
            Cells(dict.Item(k), 4) = Cells(dict.Item(k), 4) & " " & i
        Else
            dict.Add k, i
        End If
        i = i + 1
    Wend

End Sub

Answer 3

根据您的示例 #user3598756 我添加了这个单独的模块，我可以看到颜色重复，这非常有用

Sub Find_Duplicate_Entry()
Dim cel As Variant
Dim myrng As Range
Dim clr As Long
Set myrng = Range("O4:O" & Range("O65536").End(xlUp).Row)
myrng.Interior.ColorIndex = xlNone
clr = 3
For Each cel In myrng
    If Application.WorksheetFunction.CountIf(myrng, cel) > 1 Then
        If WorksheetFunction.CountIf(Range("O2:O" & cel.Row), cel) = 1 Then
            cel.Interior.ColorIndex = clr
            clr = clr + 1
        Else
            cel.Interior.ColorIndex = myrng.Cells(WorksheetFunction.Match(cel.Value, myrng, False), 1).Interior.ColorIndex
        End If
    End If
Next
End Sub

现在剩下的唯一问题是代码切换位置时。

例子：

(A302x/A402x/A6U8x)+(A235x/A3ARx)

(A402x/A302x/A6U8x)+(A235x/A3ARx)

Excel 看不到重复项，但就我而言，这是一个错误