Excel VBA mark duplicate on colA (work on all worksheet include activesheet) - excel

Question

I'd like to mark duplicate on all Worksheet in Workbook. Below the code mark only duplicate if the duplicate exist on other worksheet.
I'd like to mark them also if them exist on Activesheet.
(much better if it possible to mark on different color if duplicate exist only in Activesheet)
Here's a link for solution on similar case, What I need to solve. [a link](https://stackoverflow.com/a/25252503/5493335) "loops through the values of Col A in the sheet which gets activated and then it searches the Col A of all the remaining worksheets and if it finds the ID then it colors the cell background to red. by Siddhart Rout"
I add only one change to this code to eliminate color on empty rows.
But those code is mark(on red color) only if duplicate is one another Worksheet.
I wonder to makr on diffrent color if I found duplicate on activeworksheet.
I will trying to do myself and change the condition with else but It doesn't work. Could anybody get me some help to solve that issue.
Thanks in advance.
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

Answer 1

I'd go with the following refactoring of your code:
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

Answer 2

remove the If ws.Name <> Sh.Name Then line and end if underneath in line with it.