Excel Forum

Code: Select all

Sub Highlight_Duplicate_Entry()
    Dim ws As Worksheet
    Dim cell As Range
    Dim myrng As Range
    Dim clr As Long
    Dim dict As Object
    Dim colorIndex As Long
    Dim cellRange As Variant
    Dim rng As Variant
    Dim fullRange As Range
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' Define the ranges
    cellRange = Array("A2:A29", "D2:D29", "G2:G29", "J2:J29", "M2:M29", "P2:P29", _
                      "A30:A59", "D30:D59", "G30:G59", "J30:J59", "M30:M59", "P30:P59")
    
    ' Combine all ranges into one
    For Each rng In cellRange
        If fullRange Is Nothing Then
            Set fullRange = ws.Range(rng)
        Else
            Set fullRange = Union(fullRange, ws.Range(rng))
        End If
    Next rng
    
    Set dict = CreateObject("Scripting.Dictionary")
    colorIndex = 3  ' Start coloring from color index 3
    
    ' Clear existing colors
    fullRange.Interior.ColorIndex = xlNone
    
    ' Loop through each cell in the combined range
    For Each cell In fullRange
        If cell.Value > 0 Then ' Only consider positive values
            If Application.WorksheetFunction.CountIf(fullRange, cell.Value) > 1 Then
                If Not dict.exists(cell.Value) Then
                    dict.Add cell.Value, colorIndex
                    colorIndex = colorIndex + 1
                End If
                cell.Interior.ColorIndex = dict(cell.Value)
            End If
        End If
    Next cell
End Sub

Code: Select all

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("a2:q30,a32:q59")
        rall.Interior.Color = xlNone
        
        For Each r In rall
            If Not IsEmpty(r.Value) Then
                strVal = Sort0(r.Value)
                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 Long) As String
    Dim i As Integer, j As Integer, k As Integer
    Dim n As Integer, l As Integer, m As Integer
    Dim arr() As Variant, tmp As Variant
    For i = 1 To VBA.Len(v)
        n = VBA.Mid(v, i, 1)
        ReDim Preserve arr(m)
        arr(m) = CInt(n)
        m = m + 1
    Next i
    For k = LBound(arr) To UBound(arr)
        For l = LBound(arr) To UBound(arr) - 1
            If arr(l) > arr(k) Then
                tmp = arr(k)
                arr(k) = arr(l)
                arr(l) = tmp
            End If
        Next l
    Next k
    Sort0 = VBA.Join(arr, "")
End Function

Code: Select all

Function Sort0(v As Variant) As String
    Dim i As Integer, j As Integer
    Dim arr() As String, tmp As String
    Dim n As Integer
    
    v = CStr(v)
    
    n = Len(v)
    ReDim arr(1 To n)
    
    For i = 1 To n
        arr(i) = Mid(v, i, 1)
    Next i
    
    For i = 1 To n - 1
        For j = i + 1 To n
            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

Code: Select all

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"))
                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
    
 
    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
    
    
    Sort0 = Join(arr, "")
End Function

Code: Select all

Sub Test0()
    Dim rall As Range, r As Range, strVal As String
    Dim d As Object, x As Long, itm As Variant, stra As String
    
    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"))
                If Not d.Exists(strVal) Then
                    d.Add Key:=strVal, Item:=x & "|" & r.Address
                    r.Interior.Color = x
                    x = x + 20000
                Else
                    r.Interior.Color = VBA.Split(d.Item(strVal), "|")(0)
                    d.Item(strVal) = r.Interior.Color & "|" & ""
                End If
            End If
        Next r
        For Each itm In d.Keys
            stra = VBA.Split(d.Item(itm), "|")(1)
            If stra <> "" Then
                .Range(stra).Interior.Color = xlNone
            End If
        Next itm
    End With
    Application.ScreenUpdating = True
End Sub