[Solved] Highlighting Non-Unique Number Patterns in Multiple Columns

[artkitthana]

That is, if any set of numbers doesn't match any other box. So let it be white like before?
What I want

Sub Test0() Dim rall As Range, r As Range, strVal As String Dim d As Object, x As Long Application.ScreenUpdating = False Set d = CreateObject("Scripting.Dictionary") x = 100000 With Worksheets(1) Set rall = .Range("E2:E1000,H2:H1000,K2:K1000,N2:N1000,Q2:Q1000,T2:T1000,W2:W1000,Z2:Z1000,AC2:AC1000") rall.Interior.Color = xlNone For Each r In rall If Not IsEmpty(r.Value) Then strVal = Sort0(Format(r.Value, "000")) ' Ensure the value is treated as a string with leading zeros If Not d.Exists(strVal) Then d.Add key:=strVal, Item:=x r.Interior.Color = x x = x + 20000 Else r.Interior.Color = d.Item(strVal) End If End If Next r End With Application.ScreenUpdating = True End Sub Function Sort0(v As String) As String Dim arr() As String Dim i As Integer, j As Integer Dim tmp As String ' Convert the string to an array of single characters ReDim arr(Len(v) - 1) For i = 1 To Len(v) arr(i - 1) = Mid(v, i, 1) Next i ' Sort the array of characters For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If arr(i) > arr(j) Then tmp = arr(i) arr(i) = arr(j) arr(j) = tmp End If Next j Next i ' Join the sorted array back into a string Sort0 = Join(arr, "") End Function

 

[Lutfor Rahman Shimanto]

That is, if any set of numbers doesn't match any other box. So let it be white like before?
What I want

View attachment 1408 Sub Test0() Dim rall As Range, r As Range, strVal As String Dim d As Object, x As Long Application.ScreenUpdating = False Set d = CreateObject("Scripting.Dictionary") x = 100000 With Worksheets(1) Set rall = .Range("E2:E1000,H2:H1000,K2:K1000,N2:N1000,Q2:Q1000,T2:T1000,W2:W1000,Z2:Z1000,AC2:AC1000") rall.Interior.Color = xlNone For Each r In rall If Not IsEmpty(r.Value) Then strVal = Sort0(Format(r.Value, "000")) ' Ensure the value is treated as a string with leading zeros If Not d.Exists(strVal) Then d.Add key:=strVal, Item:=x r.Interior.Color = x x = x + 20000 Else r.Interior.Color = d.Item(strVal) End If End If Next r End With Application.ScreenUpdating = True End Sub Function Sort0(v As String) As String Dim arr() As String Dim i As Integer, j As Integer Dim tmp As String ' Convert the string to an array of single characters ReDim arr(Len(v) - 1) For i = 1 To Len(v) arr(i - 1) = Mid(v, i, 1) Next i ' Sort the array of characters For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If arr(i) > arr(j) Then tmp = arr(i) arr(i) = arr(j) arr(j) = tmp End If Next j Next i ' Join the sorted array back into a string Sort0 = Join(arr, "") End Function

Dear Artkitthana

Welcome to ExcelDemy Forum! Thanks for sharing your problem with such clarity.

I have reviewed your requirements and improved the existing sub-procedure to fulfil your goal. Please check the following:

​

Improved Excel VBA Sub-procedure:

Sub Test0()

    Dim rall As Range, r As Range, strVal As String
    Dim d As Object, x As Long, ColorIndex As Long
    Dim ColorDictionary As Object
    
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    Set ColorDictionary = CreateObject("Scripting.Dictionary")
    x = 100000
    ColorIndex = 0
    
    With Worksheets(1)
        Set rall = .Range("E2:E1000,H2:H1000,K2:K1000,N2:N1000,Q2:Q1000,T2:T1000,W2:W1000,Z2:Z1000,AC2:AC1000")
        rall.Interior.ColorIndex = xlNone
        
        For Each r In rall
            If Not IsEmpty(r.Value) Then
                strVal = Sort0(Format(r.Value, "000"))
                If Not d.Exists(strVal) Then
                    d.Add Key:=strVal, Item:=x
                    ColorDictionary.Add Key:=strVal, Item:=False
                    x = x + 20000
                Else
                    ColorDictionary(strVal) = True
                End If
            End If
        Next r
        
        For Each r In rall
            If Not IsEmpty(r.Value) Then
                strVal = Sort0(Format(r.Value, "000"))
                If ColorDictionary(strVal) Then
                    r.Interior.Color = d.Item(strVal)
                Else
                    r.Interior.ColorIndex = xlNone
                End If
            End If
        Next r
    End With
    
    Application.ScreenUpdating = True

End Sub

Function Sort0(v As String) As String
    
    Dim arr() As String
    Dim i As Integer, j As Integer
    Dim tmp As String
    
    ReDim arr(Len(v) - 1)
    For i = 1 To Len(v)
        arr(i - 1) = Mid(v, i, 1)
    Next i
    
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i) > arr(j) Then
                tmp = arr(i)
                arr(i) = arr(j)
                arr(j) = tmp
            End If
        Next j
    Next i
    
    Sort0 = Join(arr, "")

End Function

Hopefully, you have found the sub-procedure you were looking for. I have attached the workbook used to inspect your problem for better understanding. Good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy