Заливка цветом при совпадении значений из двух диапазонов.

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Заливка цветом при совпадении значений из двух диапазонов. (Макросы/Sub)

Exsodus

Дата: Вторник, 11.10.2022, 22:02 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 11

Репутация: 0 ±

Замечаний: 0% ±

Здравствуйте. На "Лист2" есть таблица со значениями и цветами, на "Лист1" при вводе значения в колонку, оно должно сравниваться со значениями в таблице на "Лист2" и при совпадении, закраситься в цвет данного значения указанного на "Лист2". Прикладываю файл-пример с макросом. Подскажите, что нужно поправить в макросе для сравнения значений с диапазоном? У меня закрашивается при указании значения и адреса ячейки с цветом в макросе? Спасибо.

К сообщению приложен файл: 9303581.xlsm (17.7 Kb)

Ответить

Nic70y

Дата: Среда, 12.10.2022, 08:09 | Сообщение № 2

Группа: Друзья

Ранг: Экселист

Сообщений: 8761

Репутация: 2273 ±

Замечаний: 0% ±

Excel 2010

[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C1:C100")) Is Nothing Then
        On Error Resume Next
        Set u = Worksheets(2).Range("b2:f12").Find(What:=Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
        v = u.Interior.Color
        w = u.Font.Color
        Range(Target, Target.Offset(0, 2)).Interior.Color = v
        Range(Target, Target.Offset(0, 2)).Font.Color = w
        If w = "" Then
            Range(Target, Target.Offset(0, 2)).Interior.Pattern = xlNone
            Range(Target, Target.Offset(0, 2)).Font.ColorIndex = xlAutomatic
        End If
    End If
End Sub

[/vba]

ЮMoney 41001841029809

Ответить

Exsodus

Дата: Воскресенье, 09.04.2023, 16:47 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 11

Репутация: 0 ±

Замечаний: 0% ±

Добрый вечер. Нужна помощь в переделке макроса. В ячейки столбца "С" будут копироваться формулой значения из ячеек столбца допустим "Н". Соответственно дальше я ввожу новое значение в столбец "Н", формула его копирует в столбец "С", дальше все как было, макрос его сравнивает с таблицей на листе2 и закрашивает соответствующим цветом. Я пробовал делать ссылку формулой из столбца "С" на столбец "Н", при вводе чиста в столбец "Н", в столбце "С" оно появляется, но ничего не закрашивается. Закрашивается только после двойного щелчка мышкой на ячейке со значением. Пробовал менять макрос с "Change" на "SelectionChange", закрашивание происходит только если выделить ячейку со значением в столбце "С". На форумах прочитал, что можно сделать макрос "Calculate", но у меня не получилось. Если не сложно, подскажите пожалуйста, как его переделать. Спасибо.
Мне Nic70y помог и скинул новый вариант макроса. Но с ним у меня получилось не совсем так, как хотелось бы, может я что-то не точно объяснил. Файл пример работы новой версии макроса прикладываю.

К сообщению приложен файл: 2_variant.xlsm (17.6 Kb)

Ответить

NikitaDvorets

Дата: Понедельник, 10.04.2023, 10:26 | Сообщение № 4

Группа: Авторы

Ранг: Ветеран

Сообщений: 557

Репутация: 126 ±

Замечаний: 0% ±

Excel 2019

Exsodus, добрый день.
Как понял, вариант Private Sub Worksheet_Change(ByVal Target As Range) в прилагаемом файле.
Закрашивание происходит при вводе нового/изменении старого значения в столбце H.

К сообщению приложен файл: okraska_jacheek_po_shablonu_dr.xlsm (22.0 Kb)

Сообщение отредактировал NikitaDvorets - Понедельник, 10.04.2023, 12:37

Ответить

Exsodus

Дата: Понедельник, 10.04.2023, 20:17 | Сообщение № 5

Группа: Пользователи

Ранг: Новичок

Сообщений: 11

Репутация: 0 ±

Замечаний: 0% ±

NikitaDvorets Спасибо, но при удалении значения из столбца H закрашивание остается. Можно сделать чтобы заливка тоже пропадала?

Ответить

NikitaDvorets

Дата: Вторник, 11.04.2023, 12:01 | Сообщение № 6

Группа: Авторы

Ранг: Ветеран

Сообщений: 557

Репутация: 126 ±

Замечаний: 0% ±

Excel 2019

Exsodus, добрый день.

Цитата

Можно сделать чтобы заливка тоже пропадала

Вполне, файл прилагается.

К сообщению приложен файл: ew_okraska_jacheek_po_shablonu.xlsm (22.6 Kb)

Ответить

Exsodus

Дата: Вторник, 11.04.2023, 20:26 | Сообщение № 7

Группа: Пользователи

Ранг: Новичок

Сообщений: 11

Репутация: 0 ±

Замечаний: 0% ±

NikitaDvorets Спасибо, но у меня при удалении значений из столбца Н периодически на эту строчку кода ошибка бывает.
[vba]

Код

If ActiveCell.Offset(-1, 0).Value = rCell.Value Then ' если редактируемая ячейка равна ячейке из диапазона матрицы цветов

[/vba]

К сообщению приложен файл: 7337827.png (31.3 Kb)

Ответить

NikitaDvorets

Дата: Вторник, 11.04.2023, 22:21 | Сообщение № 8

Группа: Авторы

Ранг: Ветеран

Сообщений: 557

Репутация: 126 ±

Замечаний: 0% ±

Excel 2019

Exsodus, оптимизировал блок кода (прилагаю), обрабатывающий удаление.
Если ошибка будет повторяться, пришлите свой рабочий файл.

К сообщению приложен файл: 7775881.xlsm (22.3 Kb)

Ответить

i691198

Дата: Среда, 12.04.2023, 20:38 | Сообщение № 9

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 218

Репутация: 85 ±

Замечаний: 0% ±

Exsodus, Попробуйте такой вариант. Подход немного другой, макрос более быстрый.
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("H1:H18")) Is Nothing Or Target.Count <> 1 Then Exit Sub
    Dim Dk As Object, Cl As Range
    Range("C1:E18").Interior.Color = 16777215
    Set Dk = CreateObject("Scripting.Dictionary")
    With Worksheets("Лист2")
       For Each Cl In .Range("B2:F12")
         Dk.Add Cl.Value, Cl.Interior.Color
       Next
    End With
    For Each Cl In Range("H1:H18")
       Cl.Offset(, -5) = Cl
       If Dk.Exists(Cl.Value) Then Cl.Offset(, -5).Resize(, 3).Interior.Color = Dk(Cl.Value)
    Next
End Sub

[/vba]

Сообщение отредактировал i691198 - Среда, 12.04.2023, 20:39

Ответить

Страница 1 из 1
1