Excel 2013 VBA to Highlight Unique Value If Value Found On Any Other Worksheet

[SweetA1217]

Excel 2013 VBA to Highlight Unique Value If Value Found On Any Other Worksheet
Can anyone help me write VBA code to Highlight a Unique Value on a Worksheet (Shop Agenda) if that same unique value is located on another other worksheet in the workbook. Here is the kicker: I cannot hardcode the name of the other worksheets because I have written code to pull multiple workbooks into a single workbook. Therefore, the names of the other worksheets are subject to change.

In Worksheet "Shop Agenda", I want to check if any values in row B (starting at B3 and Range(Selection, Selection.End(xlDown))) is in any other worksheet. If the value is in another worksheet, then highlight that unique value on the "Shop Agenda" worksheet.

I have found code to look at another worksheet for which the worksheet name is known and hardcoded. In this case, the worksheet name will not be known until the worksheet is pulled into the workbook.

Here is the code that I am playing with:

Sub HighlightPriority()
Dim ws As Worksheet
Dim ShopTable As Range
Dim PriorityTable As Range
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim lastRow As Long
Dim cell As Range
Dim Imp_Row As Integer
Dim Imp_Col As Integer

Worksheets("Shop Agenda").Activate
Set ShopTable = Range("B3", Range("B3").End(xlDown))

For Each ws In ThisWorkbook.Worksheets
sSheetName = ActiveSheet.Name
Set PriorityTable = ActiveSheet.Columns("A:Q") '<=== "A:Q" is placeholder, do not know what columns will be on other worksheet

With Worksheets(sSheetName)
lastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row

For Each cell In ShopTable
PriorityTable.Cells(Imp_Row, Imp_Col) = Application.WorksheetFunction.VLookup(cell, PriorityTable, 1, False) '<=== Cannot use VLookup b/c will not know where unique value is located
Imp_Row = Imp_Row + 1
If cell.Value = Cells(Imp_Row, Imp_Col) Then
cell.EntireRow.Interior.ColorIndex = 39
Else
cell.EntireRow.Interior.ColorIndex = xlNone
End If
Next cell

End With

Next ws

 

[SweetA1217]

Try

Sub SweetA()
   Dim Ary As Variant
   Dim r As Long, c As Long
   Dim Cl As Range
   Dim WS As Worksheet
   Dim Dic As Object
 
   Set Dic = CreateObject("scripting.dictionary")
   Dic.CompareMode = 1
   With Sheets("Shop Agenda")
      For Each Cl In .Range("B3", .Range("B" & Rows.Count).End(xlUp))
         Set Dic(Cl.Value & "") = Cl
      Next Cl
   End With
   For Each WS In Worksheets
      If Not WS.Name = "Shop Agenda" Then
         Ary = WS.UsedRange.Value2
         If Not IsEmpty(Ary) Then
            For r = 1 To UBound(Ary)
               For c = 1 To UBound(Ary, 2)
                  If Dic.Exists(Ary(r, c) & "") Then
                     Dic(Ary(r, c) & "").Interior.ColorIndex = 39
                     Dic.Remove Ary(r, c) & ""
                  End If
               Next c
            Next r
         End If
      End If
   Next WS
End Sub

YES!!! Thank you for working through this with me!!!

 

[Fluff]

You're welcome & thanks for the feedback.