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

#### artkitthana

##### New member
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 ```

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:
Code:
``````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
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

#### Attachments

• Artkitthana (SOLVED).xlsm
45 KB · Views: 0

Members online
0
Guests online
34
Total visitors
34