search for duplicates and mark on color match - string from col (AB) col(PR) in all Workbook

[mokie]

Hello, I have some tool to work to comprae cuplicates and mark if exist by the one cell.
Now I need compare workbook from 2 column (creating string from 2 column)

How it should be work:

If I wrote in A = nothing
If I wrote in A and B smg it should automatickly find duplicates in workbook and mark on color.
also I'd like to looking for duplicat in for 2 ranges in worksheets in all workbook.
Sheet1:AB
Sheet1 PR
Sheet2:AB
Sheet2 PR
and so on:

first loop starts looking for match in AB then PR , AB , PR... the same value.


That's the one tool from 1 column what i use from workbook.
Also usefull will if it separete if it was founding in activesheet or othersheet.

1st code it's not sorking for duplicates in activesheet

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
            Dim lRow As Long, wsLRow As Long, i As Long
            Dim aCell As Range
            Dim ws As Worksheet
            Dim strSearch As String
         
            With Sh
                '~~> Get last row in Col A of the sheet
                '~~> which got activated
                lRow = .Range("A" & .Rows.Count).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(1).Interior.ColorIndex = xlNone
             
                '~~> Loop through the cells of the sheet which
                '~~> got activated
                For i = 1 To lRow
                    '~~> Store the ID in a variable
                    strSearch = .Range("A" & i).Value
                    if strSearch <> "" then 'eliminated color empty cell
 
                    '~~> 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("A" & ws.Rows.Count).End(xlUp).Row
                         
                            '~~> Use .Find to quick check for the duplicate
                            Set aCell = ws.Range("A1:A" & 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("A" & i).Interior.ColorIndex = 3
                                Exit For
                            End If
                        End If
                    Next ws
                      End if
                Next i
            End With
        End Sub

2nd code (marks on 3 colors depends of scenerio.

 'code created by user3598756
        Private Sub Workbook_SheetActivate(ByVal Sh As Object)
            Dim IDsRng As Range, IDCell As Range
            Dim ws As Worksheet
            Dim strSearch As String
            Dim foundInOtherSheet As Boolean, foundInActiveSheet As Boolean
     
            With Sh
                Set IDsRng = .Range("A1", .Cells(.Rows.count, 1).End(xlUp)) '<--| set the IDs range as all column A not empty cells with some "text" content
                '~~> 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(1).Interior.ColorIndex = xlNone
            End With
     
     
            For Each IDCell In IDsRng '<--| Loop through ID cells (i.e. column A "text" cells of the activated sheet)
                '~~> Store the ID in a variable
                strSearch = IDCell.Value
     
                foundInActiveSheet = WorksheetFunction.CountIf(IDsRng, strSearch) > 1 '<--| count possible dupes in active sheet
                foundInOtherSheet = False '<--| initialize it at every new ID
     
                '~~> 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
                        With ws
                            foundInOtherSheet = WorksheetFunction.CountIf(.Range("A1", .Cells(.Rows.count, 1).End(xlUp)), strSearch) > 1
                            If foundInOtherSheet Then Exit For '~~> If found then color then no point searching rest of the sheets
                        End With
                    End If
                Next
     
                Select Case True '<--| now act accordingly to where duplicates have been found
                    Case foundInOtherSheet And Not foundInActiveSheet '<--| if duplicates found in "other" sheets only
                        IDCell.Interior.ColorIndex = 3 '<--| red
                    Case foundInOtherSheet And foundInActiveSheet '<--| if duplicates found in "other" sheets and in "active" one too
                        IDCell.Interior.ColorIndex = 6 '<--| yellow
                    Case Not foundInOtherSheet And foundInActiveSheet '<--| if duplicates found in "active" sheets only
                        IDCell.Interior.ColorIndex = 14 '<--| green
                End Select
     
            Next
        End Sub

 

[mokie]

I found another intresting example for my cases. I change it for my issue as well as I can. It's work for string but not exactly as good as I like.

What is most important for me is two issue to develope.

Now is working only on 1 worksheets. (I'd like to work for all workbook)
Now is worknig only in fixed one ranges AB (I'd like to add to AB to check also range PR)

I will be very greatful if somebody could looking for code below and give hints or help develop the code.

'in module

Sub Duplicates_2()

Application.ScreenUpdating = False

Dim lastRow As Long, NamesCol As Long, EmailCol As Long

lastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

NamesCol = 1 'A column with numbers or words

EmailCol = 2 'C column with numbers

Columns(NamesCol).Interior.ColorIndex = xlNone

For i = 1 To lastRow

If 1 < Application.WorksheetFunction.CountIfs(Range(Cells(1, NamesCol), Cells(lastRow, NamesCol)), _

  Cells(i, NamesCol), _

  Range(Cells(1, EmailCol), Cells(lastRow, EmailCol)), _

  Cells(i, EmailCol)) _

  Then Range(Cells(i, 1), (Cells(i, 2))).Interior.ColorIndex = 3

Next i

End Sub

'in worksheets
Private Sub Worksheet_Change(ByVal Target As Range)
' When col 2 entered macro is triggered to flag duplicate entries
If Target.Column = 2 Then
Call Duplicates_2
End If
End Sub

Thanks in advanced.