EXCEL Найти и покрасить в диапазоне из диапазона(ов)

Все знакомы с условным форматированием?
УФ позволяет форматировать ячейки в зависимости от их значений. Один из вариантов:
Найти в диапазоне все вхождения "БЛА".
Создаем правило для диапазона ($A$1:$A$150) с
формулой =СЧЁТЕСЛИ($A$1:$A$150;"БЛА")
И все. А что делать если у нас не "БЛА", а целый диапазон/массив (называйте как хотите) значений??? Я не нашел ответа, как это сделать формулой (для сравнения столбцов есть, но у меня с одной стороны таблица 31 столбец * 70 строк, с другой 71 строка * 1 столбец).
Пришлось использовать VBA.

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

Вот мой вариант:

calendar =СМЕЩ(Лист1!$A$2;;1;СЧЁТЗ(Лист1!$A$1:$A$65539);31), где в ячейках столбца А просто стоит цифра 1 (СЧЕТЗ считает значения для высоты, если в промежутке ячейка пуста, то высота будет на N меньше), третий параметр смещение к столбцу В (дабы не учитывать столбец А), последний параметр ширина таблицы.
array_date =СМЕЩ(Лист1!$AL$4;;;СЧЁТЗ(Лист1!$AL$1:$AL$65539);1), ну здесь все понятно

Создаем макрос с таким кодом:

Sub Поиск()
Dim isk_array As Range
Set isk_array = Range("array_date")
Dim find_array As Range
Set find_array = Range("calendar")
Dim cell_back As Range
Set cell_back = Range("AJ7") 'ИЗ ЭТОЙ ЯЧЕЙКИ БЕРЕМ ЦВЕТ ЗАЛИВКИ
Dim empt As Integer
'Очищаем заливку для всей таблицы
find_array.Interior.ColorIndex = xlNone
'ОБХОДИМ СПИСОК ДАТ
For Each isk_date In isk_array
    'ЕСЛИ НЕ ПУСТО НАЧИНАЕМ
    If Not isk_date = "" Then
        'ЭТО ПОНАДОБИТСЯ ПОТОМ
        empt = "1"
        'ОБХОДИМ КАЛЕНДАРЬ
        For Each find_cell In find_array
            'ЕСЛИ ДАТА ИЗ СПИСКА РАВНА ДАТЕ ИЗ КАЛЕНДАРЯ ПО ТЕКУЩЕЙ ИТЕРАЦИИ И Т.Д.
            If find_cell = isk_date Then
                'ПРОВЕРЯЕМ НЕ СТАРЫЙ/НОВЫЙ МЕСЯЦ В ТЕКУЩЕМ МЕСЯЦЕ КАЛЕНДАРЯ
                If find_cell.Font.ColorIndex = 1 Then
                    'ЗДЕСЬ ПРОВЕРКА, ЗАЛИТА ЯЧЕЙКА ДЛЯ ПОДБОРА ЦВЕТА ИЛИ НЕТ
                    If Not cell_back.Interior.ColorIndex = xlNone Then
                        'ЗАЛИВАЕМ ЯЧЕЙКУ
                        find_cell.Interior.ColorIndex = cell_back.Interior.ColorIndex
                        'ВОЛШЕБНАЯ ГАЛОЧКА
                        empt = "0"
                    Else
                        MsgBox ("Ячейка " & cell_back & " не имеет заливки")
                        'ВЫХОД
                        Exit Sub
                    End If
                End If
            End If
        Next
        'ПРОВЕРЯЕМ ВОЛШЕБНУЮ ГАЛОЧКУ, ЕСЛИ ОНА ВСЕ ТАКЖЕ РАВНО 1 ТОГДА - ОШИБКА: ДАТА НЕ НАЙДЕНА
        If empt = "1" Then
            MsgBox ("Таблица не сожержит значение:  " & isk_date.Value & " !!!")
            End If
    Else
    End If
Next
End Sub

Создаем кнопочку на форме, и все :-)

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

И еще момент, на глаз цвет ячейки для и заливки и заливка найденных разная, это связано с тем что палитра для ColorIndex на много меньше
Скачать пример

EXCEL Найти и покрасить в диапазоне из диапазонОВ

А как сделать тоже самое, но искомое хранится в нескольких диапазонах, и разные цвета???

Диапазоны я расположил на отдельном листе:

А1 - это цвет для повторяющихся значений. На строке C2:XFD2 (именованный диапазон array_array) хранятся названия именованных диапазонов, которые записаны в Диспетчере имен (названия должны совпадать)

Осталось дело за малым - vba:

Sub Поиск()
Dim array_array As Range
Set array_array = Range("array_array") 'СПИСОК ДИАПАЗОНОВ
Dim find_array As Range
Set find_array = Range("array_table") 'ФОРМАТИРУЕМАЯ ТАБЛИЦА
Dim back_default As Range
Set back_default = Range("back_default") 'ИЗ ЭТОЙ ЯЧЕЙКИ БЕРЕМ ЦВЕТ ЗАЛИВКИ ДЛЯ СОВПАДАЮЩИХ
Dim empt As Integer
Dim isk_array As Range
Dim cell_back As Range
find_array.Interior.ColorIndex = xlNone 'СНИМАЕМ ЗАЛИВКУ
For Each cell_array In find_array
    With cell_array
        .ClearComments
    End With
Next
'НАЧИНАЕМ ОБХОД СПИСКА ДИАПАЗОНОВ
For Each arr_array In array_array
    If Not arr_array = "" Then
        Set isk_array = Range(arr_array.Value) 'ПЕРЕДАЕМ НАЗВАНИЕ ДИАПАЗОНА
        Set cell_back = arr_array.Offset(1, 0) 'ПОЛУЧАЕМ ЯЧЕЙКУ НИЖЕ, В НЕЙ ЗАЛИВКА
    Else
        Exit For
    End If
    'ОБХОДИМ СПИСОК ДАТ
    For Each isk_date In isk_array
        'ЕСЛИ НЕ ПУСТО НАЧИНАЕМ
        If Not isk_date = "" Then
            'ЭТО ПОНАДОБИТСЯ ПОТОМ
            empt = "1"
            'ОБХОДИМ КАЛЕНДАРЬ
            For Each find_cell In find_array
                'ЕСЛИ ДАТА ИЗ СПИСКА РАВНА ДАТЕ ИЗ КАЛЕНДАРЯ ПО ТЕКУЩЕЙ ИТЕРАЦИИ И Т.Д.
                If find_cell = isk_date Then
                    'ПРОВЕРЯЕМ НЕ СТАРЫЙ/НОВЫЙ МЕСЯЦ В ТЕКУЩЕМ МЕСЯЦЕ КАЛЕНДАРЯ
                    If find_cell.Font.ColorIndex = 1 Then
                        'ЗДЕСЬ ПРОВЕРКА, ЗАЛИТА ЯЧЕЙКА ДЛЯ ПОДБОРА ЦВЕТА ИЛИ НЕТ
                        If Not cell_back.Interior.ColorIndex = xlNone Then
                            'ЗАЛИВАЕМ ЯЧЕЙКУ
                            If find_cell.Interior.ColorIndex = xlNone Then
                                Col = cell_back.Interior.Color
                            Else
                                Col = back_default.Interior.Color
                                With find_cell 'Добавление
                                    .ClearComments
                                    .AddComment
                                    .Comment.Text "Данное значение повторяется в нескольких диапазонах"
                                End With
                            End If
                              find_cell.Interior.Color = Col
                            'ВОЛШЕБНАЯ ГАЛОЧКА
                            empt = "0"
                            Exit For ' выход при первом вхождении
                        Else
                            MsgBox ("Ячейка " & cell_back & " не имеет заливки")
                            'ВЫХОД
                            Exit Sub
                        End If
                    End If
                End If
            Next
            'ПРОВЕРЯЕМ ВОЛШЕБНУЮ ГАЛОЧКУ, ЕСЛИ ОНА ВСЕ ТАКЖЕ РАВНО 1 ТОГДА - ОШИБКА: ДАТА НЕ НАЙДЕНА
            If empt = "1" Then
                MsgBox ("Таблица не сожержит значение:  " & isk_date.Value & " !!!")
                End If
        Else
        End If
    
    Next
Next
End Sub

Ну вот и все :-)

В этом примере выход из перебора календаря при первом вхождении, для заливки используется не ColorIndex, а Color (rgb) , поэтому цвета одинаковые.

Также можно отказаться от именованных диапазонов, оставив только back_default,array_array и array_table, но придется научить макрос рассчитывать самому диапазоны.


Скачать пример