excel – find不同排列的多个重复值
我正在寻找使我的生活更轻松，并编写一个脚本，在Excel中search并突出显示重复值。
例如，我有2行复杂的值。 第一行不是那么重要，因为它只是一个名字，但第二个是重要的，在这里我不知道如何search重复。 一件重要的事情是价格是相同的，但有时可能有不同的写法。
你能帮我吗，而我仍然手动search，2小时后，我失去了我的视线和心灵:)
你可以利用：
-
SortedList对象，在每个“代码”单元格中创build一个独立于“值”出现顺序的代码键 -
Dictionary对象，收集所有对应于相同代码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
一个可能有助于开始的示例代码
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
基于你的例子＃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看不到重复，但对我来说，这是一个错误