Okay, try this to see if you get the desired result.
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim ws As Worksheet
Dim lr As Long
Dim Rng As Range, Cell As Range, pCell As Range
Application.ScreenUpdating = False
lr = Sh.Cells(Rows.Count, 2).End(xlUp).Row
If lr < 2 Then Exit Sub
Set Rng = Sh.Range("B2:B" & lr)
Rng.Interior.ColorIndex = xlNone
For Each Cell In Rng
For Each ws In ThisWorkbook.Sheets
If ws.Name <> Sh.Name Then
If Application.CountIf(ws.Columns(2), Cell.Value) > 0 Then
Cell.Interior.Color = vbYellow
End If
Set pCell = ws.Columns(2).Find(Cell.Value, lookat:=xlWhole)
If Not pCell Is Nothing Then
If pCell.Offset(0, 1) <> "" Then Cell.Offset(0, 1) = pCell.Offset(0, 1)
End If
End If
Set pCell = Nothing
Next ws
Next Cell
Application.ScreenUpdating = True
End Sub
Bookmarks