Как в Excel найти ВСЕ одинаковые значения в разных листах?

Question

[AlexCruel]

Множество листов в одном доке. Первый столбец у всех одинаковый (например, название). У меня есть макрос, который выделяет на одном листе повторяющиеся значения РАЗНЫМ цветом. Хотелось бы, чтобы и на других тоже выделялось ТЕМ ЖЕ цветом, что и на первом. Как реализовать?

Sub DuplicatesColoring()
     
    Dim Dupes()     'объявляем массив для хранения дубликатов
    ReDim Dupes(1 To Selection.Cells.Count, 1 To 2)
     
    Selection.Interior.ColorIndex = -4142   'убираем заливку если была
    i = 3
    For Each cell In Selection
        If WorksheetFunction.CountIf(Selection, cell.Value) > 1 Then
            For k = LBound(Dupes) To UBound(Dupes)
                'если ячейка уже есть в массиве дубликатов - заливаем
                If Dupes(k, 1) = cell Then cell.Interior.ColorIndex = Dupes(k, 2)
            Next k
            'если ячейка содержит дубликат, но еще не в массиве - добавляем ее в массив и заливаем
            If cell.Interior.ColorIndex = -4142 Then
                cell.Interior.ColorIndex = i
                Dupes(i, 1) = cell.Value
                Dupes(i, 2) = i
                i = i + 1
            End If
        End If
    Next cell
End Sub

Answer 1

[h8nor]

Я бы использовал коллекции, в которых можно отсекать дубликаты значений. Раз вы привыкли к выделению блоков, то вот пример перебора выделенных блоков в листах справа от активного.

Option Explicit
'123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789
Private IndexColors As New Collection, CurrentColor As Integer, BaseSheetIndex As Byte

Sub DuplicatesColoring()
  Dim cell As Range, selected As Range
  
  Set selected = Selection
  If BaseSheetIndex = 0 Then _
    BaseSheetIndex = ActiveSheet.Index: CurrentColor = 3 ' Начальные значения
  selected.Interior.ColorIndex = -4142 ' Убрать заливку
  
  For Each cell In selected
    If Not IsEmpty(cell.Value) Then
      On Error Resume Next ' Включить обработку исключений
        If BaseSheetIndex = ActiveSheet.Index _
        And WorksheetFunction.CountIf(selected, cell.Value2) > 1 Then
          IndexColors.Add CurrentColor, CStr(cell.Value2) ' Заполнить коллекцию
          If Not Err.Number = 457 Then CurrentColor = CurrentColor + 1
        End If
        
        cell.Interior.ColorIndex = IndexColors(CStr(cell.Value2))
      On Error GoTo 0
    End If
  Next cell
  
  Do Until ActiveSheet.Index > ActiveWorkbook.Sheets.Count - 1
    ActiveWorkbook.Sheets(ActiveSheet.Index + 1).Activate
    DuplicatesColoring
    Exit Sub ' Предотвратить бесконечную рекурсию
  Loop
  
  Worksheets(BaseSheetIndex).Activate
End Sub

Comments

[AlexCruel]

Спасибо за ответ!
Получается, если на первом листе не будет значений больше 1, то он не будет подсвечиваться, даже, если они имеются на других?
Если прописать = 0, то на первом листе будут подсвечены ВСЕ значения => и на других листах тоже.
Придется выбирать между этими вариантами.

[h8nor]

Да. Одновременно с этим участвует условие добавление значения в коллекции с исходного (активного) листа BaseSheetIndex = ActiveSheet.Index. Только учтите, что количество значений индекса палитры, который вы изначально решили применять, довольно ограничено Excel 2010 и 2013 по разному кодируют цвета? И вообще где почитать про различия для разных версий офиса?

[AlexCruel]

Дѣаволъ, простите, не могли бы вы мне помочь? Можно ли реализовать поиск дублей по ВСЕМ листам сразу? Чтобы не удалялось автоматически, а пользователь смог принять решение - удалять или нет? Или, хотя бы, одинаковым цветом выделить для всех, например, только розовым?
То есть: первый лист смотрит на другие и сверяет со своим списком; потом второй лист сверяет свои значения со всеми, включая ПЕРВЫЙ и т.д.
Буду очень благодарен, спасибо!

[h8nor]

AlexCruel, создайте новый вопрос (как требуют правила площадки). Под ним будет ссылка "Пригласить эксперта".

[AlexCruel]

Дѣаволъ, спасибо за ответ. Уже сам справился)