Snasui Excel Forum

Code: Select all

Sub Duplicate()

    Dim lRow As Long, wsLRow As Long, i As Long
    Dim aCell As Range
    Dim ws As Worksheet, sh As Worksheet
    Dim strSearch As String
    Dim show As Integer
    
    show = 0
    
    Set sh = ActiveSheet()

    With sh
        '~~> Get last row in Col A of the sheet
        '~~> which got activated
        'lRow = sh.Range("C6", sh.Range("C6").End(xlDown)).Rows.Count
        lRow = Cells(Rows.Count, "C").End(xlUp).Row

        '~~> Remove existing Color from the column
        '~~> This is to cater for any deletions in the
        '~~> other sheets so that cells can be re-colored
        
        .Columns(3).Interior.ColorIndex = xlNone

        '~~> Loop through the cells of the sheet which
        '~~> got activated
        For i = 6 To lRow
            '~> Store the ID in a variable
           strSearch = .Range("C" & i).Value
            
            If strSearch <> "" Then
            '~~> loop through the worksheets in the workbook
            For Each ws In ThisWorkbook.Worksheets
                '~~> This is to ensure that it doesn't
                '~~> search itself
                If ws.Name <> sh.Name Then
                    '~~> Get last row in Col A of the sheet
                    wsLRow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row

                    '~~> Use .Find to quick check for the duplicate
                    Set aCell = ws.Range("C6:C" & wsLRow).Find(What:=strSearch, _
                                                               LookIn:=xlValues, _
                                                               LookAt:=xlWhole, _
                                                               SearchOrder:=xlByRows, _
                                                               SearchDirection:=xlNext, _
                                                               MatchCase:=False, _
                                                               SearchFormat:=False)

                    '~~> If found then color the cell red and exit the loop
                    '~~> No point searching rest of the sheets
                    If Not aCell Is Nothing Then
                        sh.Range("C" & i).Interior.ColorIndex = 3
                        show = 1
                        Exit For
                    End If
                End If
            Next ws
            End If
        Next i
    End With
    
    '------------------------------------------'
    
    Dim lastRow As Long
    Dim matchFoundIndex As Long
    Dim iCntr As Long, iCntr2 As Long
    
    With sh
    'lastRow = Cells(Rows.Count, "C").End(xlUp).Row
    'lastRow = sh.Range("C6", sh.Range("C6").End(xlDown)).Rows.Count
    'lastRow = .Range("C" & .Rows.Count).End(xlUp).Row
    'lastRow = lRow
    iCntr = 6
    For iCntr = 6 To lRow
    If Cells(iCntr, 6) <> "" Then
        matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 3), Range("C6:C" & iCntr), 0)
        If iCntr <> matchFoundIndex Then
            Cells(iCntr, 3).Interior.ColorIndex = 3
            show = 1
        
        If iCntr = matchFoundIndex And iCntr <> lRow Then
            iCntr2 = iCntr + 1
            matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 3), Range("C" & iCntr2 & ":C" & lRow), 0)
        End If
            If iCntr <> matchFoundIndex Then
                Cells(iCntr, 3).Interior.ColorIndex = 3
                show = 1
            End If
        End If
    End If
    Next
    
    '-------------------------------------------'
    
    End With
        
    If show = 1 Then
        MsgBox ("Duplicate ID Sheet")
    End If


End Sub