excel - find multiple duplicated values with different arrangement

Question

I'm looking to make my life easier and write a script that searches and highlights duplicated value in Excel.

I have, as example, 2 Rows with complex values. First Row is not so important cause it's only a name, but the second is important and here I can't figure it out how to search for duplicates. One big thing is that the vale is the same, but it can be sometimes differently written.

Can you please help me, while i still search it manually and after 2 hours I lost my sight and mind :)

Answer 1

Based on your Example #user3598756 I have added this separate Module and I can see duplicates in colors which is extremely helpful

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

Now the only problem left is when the Codes have switched positions.

Example:

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

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

Excel sees no duplicates, but for my case, it's an Error

Answer 2

you could exploit:

• SortedList object, to create a code Key which is independent of "values" occurrence order in each column "Code" cells

• Dictionary object, to collect all "persons" corresponding to the same code Key

as follows:

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 3

a sample code that might help to start with

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