@AlexCruel

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

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

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
  • Вопрос задан
  • 140 просмотров
Решения вопроса 1
bopoh13
@bopoh13
VBA, Ruby (noob), analytic
Я бы использовал коллекции, в которых можно отсекать дубликаты значений. Раз вы привыкли к выделению блоков, то вот пример перебора выделенных блоков в листах справа от активного.
Option Explicit
'12345678901234567890123456789012345bopoh13@ya67890123456789012345678toster56789
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
Ответ написан
Пригласить эксперта
Ваш ответ на вопрос

Войдите, чтобы написать ответ

Войти через центр авторизации
Похожие вопросы
12 июл. 2020, в 19:31
2000 руб./за проект
12 июл. 2020, в 16:53
500 руб./за проект
12 июл. 2020, в 16:28
3000 руб./за проект