Выделить цветом дубликаты значений во всех листах книги

В цикле каждый из листов книги выбираем как лист-образец, сверяем его значения со значениями всех листов (включая лист-образец)...

Без оптимизации. Листы-образцы не исключаются из дальнейшей проверки и заливка ячеек может повторяться по несколько раз. На результат не влияет, но - дополнительное время на обработку.

Sub ColorsDoubles()
    Dim sht1 As Worksheet, sht2 As Worksheet
    Dim rRng1 As Range, rRng2 As Range, c1 As Range, c2 As Range
    Dim lColor As Long

    lColor = RGB(250, 150, 150)
    Application.ScreenUpdating = False

    For Each sht1 In Worksheets
        Set rRng1 = sht1.UsedRange
        
        For Each sht2 In Worksheets
            Set rRng2 = sht2.UsedRange
            
            For Each c1 In rRng1
                If c1.Value <> "" Then
                    For Each c2 In rRng2
                        If c1.Address <> c2.Address Then
                            If c1.Value = c2.Value Then c2.Interior.Color = lColor
                        End If
                    Next c2
                End If
            Next c1
        Next sht2
    Next sht1
    
    Set rRng1 = Nothing: Set rRng2 = Nothing           
    Application.ScreenUpdating = True
End Sub

Как вариант ускорения: создать массив с именами листов.

В примере красным закрашиваются ячейки, у которых есть дубли или на этом же листе, или на следующих. Зеленые - последние дублированные значения.

Sub ColorsDoubles()
    Dim sht As Worksheet
    Dim aNameSheets()
    Dim rRng1 As Range, rRng2 As Range, c1 As Range, c2 As Range
    Dim lCountSheets As Long, lColor1 As Long, lColor2 As Long
    Dim i As Long, n As Long
    
    lCountSheets = ThisWorkbook.Sheets.Count
    ReDim aNameSheets(1 To lCountSheets)
    
    For Each sht In Worksheets
         n = n + 1
    
         With sht
             aNameSheets(n) = .Name 'имя листа в массив' 
             .UsedRange.Interior.Pattern = xlNone 'удаление заливки на листе'
         End With
     Next sht
    
    lColor1 = RGB(200, 150, 150) 'цвета'
    lColor2 = RGB(150, 200, 150)
    Application.ScreenUpdating = False

    For i = 1 To lCountSheets
        Set rRng1 = Worksheets(aNameSheets(i)).UsedRange 'диапазон листа-образца'
        
        For n = i To lCountSheets
            Set rRng2 = Worksheets(aNameSheets(n)).UsedRange 'диапазоны следующих листов'
            
            For Each c1 In rRng1
                If c1.Value <> "" Then 'если значение в ячейке-образце есть'
                    For Each c2 In rRng2
                        If i = n And c1.Address = c2.Address Then
                        Else 'если сравнивается не сама с собой'
                            If c1.Value = c2.Value Then 'если значения совпали'
                                c1.Interior.Color = lColor1 'красим'
                                c2.Interior.Color = lColor2
                            End If
                        End If
                    Next c2
                End If
            Next c1
        Next n
    Next i
                
    Set rRng1 = Nothing: Set rRng2 = Nothing 'освобождаем память'
    Application.ScreenUpdating = True
End Sub

Мою проблему мне помогли решить тут

Вот решение, пусть и не совсем такое, как изначально предполагалось. Данный макрос ищет дубликаты в столбце с заданным именем и выводит список значений с указанием их местоположений.

Sub UniqArticul()
Dim Sht As Worksheet
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim ColArticul As Integer
Dim dict As Object
Dim arr
Dim Col As String

Col = Application.InputBox("Укажите название столбца", , , , , , , 2)

ThisWorkbook.Sheets.Add.Name = "Дубликаты"

   Set dict = CreateObject("Scripting.Dictionary"): dict.comparemode = 1
  For Each Sht In Worksheets
    If Sht.Name <> "Дубликаты" Then
      With Sht
       Set FoundCell = .Rows(1).Find(Col, , xlValues, xlWhole)
        If Not FoundCell Is Nothing Then
          ColArticul = FoundCell.Column
          iLastRow = .Cells(.Rows.Count, ColArticul).End(xlUp).Row
          arr = .Range(.Cells(2, ColArticul), .Cells(iLastRow, ColArticul))
          For i = 1 To UBound(arr)
            dict.Item(arr(i, 1)) = dict.Item(arr(i, 1)) + Sht.Name & " строка: " & i + 1 & "; "
          Next
        End If
        Set FoundCell = Nothing
      End With
    End If
  Next
   Columns("C:D").ClearContents
   Range("C1").Resize(dict.Count, 2) = Application.Transpose(Array(dict.keys, dict.Items))
End Sub