Поиск ячеек с одинаковым значением и заливка цветом

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

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

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

vitzer

Дата: Среда, 21.12.2016, 01:17 | Сообщение № 1

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

Ранг: Прохожий

Сообщений: 8

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

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

Excel 2007

Здравствуйте!
Раньше лопатил таблицу вручную, но теперь объем данных увеличился и нужна автоматизация, так как другой работы полно.
Прошу подсказать решение: например, кинуть ссылку на похожее решение. Поиском не нашел... (или плохо искал).
Задача. Имеем две колонки со списками слов и словосочетаний, каждая из которых имеет числовое значение в соседней колонке. Один набор данных старый (справа), уже размеченный необходимым цветом, а другой - новый (слева). Так как в новой колонке список постоянно увеличивается, то необходимо определить ячейки с одинаковыми словами в новом наборе данных и окрасить в цвета, соответствующие старым данным.
Неокрашенные ячейки и будут вновь выявленными. Прием с окрашиванием очень важен.
Во вложении пример: в первой вкладке конечный результат, а во второй - исходник.

К сообщению приложен файл: 17_11-01_12.xlsx (23.2 Kb)

Сообщение отредактировал vitzer - Среда, 21.12.2016, 01:31

Ответить

dim34rus

Дата: Среда, 21.12.2016, 02:03 | Сообщение № 2

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

Ранг: Участник

Сообщений: 66

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

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

Excel 2007 - 2013

Пожалуйста...
[vba]

Код

Sub Colored()
   i = 2
   While ActiveSheet.Cells(i, 5).Value <> ""
      k = 2
      While (ActiveSheet.Cells(k, 1).Value <> "") And (ActiveSheet.Cells(k, 1).Value <> ActiveSheet.Cells(i, 5).Value)
        k = k + 1
      Wend

      If ActiveSheet.Cells(k, 1).Value = ActiveSheet.Cells(i, 5).Value Then

          ActiveSheet.Cells(k, 1).Interior.Pattern = ActiveSheet.Cells(i, 5).Interior.Pattern
          ActiveSheet.Cells(k, 1).Interior.PatternColorIndex = ActiveSheet.Cells(i, 5).Interior.PatternColorIndex
          ActiveSheet.Cells(k, 1).Interior.ColorIndex = ActiveSheet.Cells(i, 5).Interior.ColorIndex
          ActiveSheet.Cells(k, 1).Interior.Color = ActiveSheet.Cells(i, 5).Interior.Color
          If ActiveSheet.Cells(i, 5).Interior.ThemeColor > 0 Then
             ActiveSheet.Cells(k, 1).Interior.ThemeColor = ActiveSheet.Cells(i, 5).Interior.ThemeColor
          End If
          ActiveSheet.Cells(k, 1).Interior.TintAndShade = ActiveSheet.Cells(i, 5).Interior.TintAndShade
          ActiveSheet.Cells(k, 1).Interior.PatternTintAndShade = ActiveSheet.Cells(i, 5).Interior.PatternTintAndShade
      End If
      i = i + 1
   Wend
End Sub

[/vba]

Только что-то мне подсказывает что в примере не совсем корректно раскрасили ячейки. Опять таки в задании надо раскрашивать правую, а в примере наоборот - левую колонку. Короче макрос красит лекую колонку по образцу правой. Если надо наоборот, то во всех адресах ячеек Cells(...., 1) поменять 1 на 5, и 5 на 1 .
ЗЫЖ взаимное расположение данных (т.е в каких колонках и с каких строк начинается, для макроса - важно!

Пожалуйста...
[vba]

Код

Извращение - это писать формулы в Word'овских таблицах.
ЯД 410014340958327

Сообщение отредактировал dim34rus - Среда, 21.12.2016, 02:04

Ответить

СообщениеПожалуйста...
[vba]

Код

Автор - dim34rus
Дата добавления - 21.12.2016 в 02:03

krosav4ig

Дата: Среда, 21.12.2016, 04:23 | Сообщение № 3

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

Ранг: Старожил

Сообщений: 2347

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

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

Excel 2007,2010,2013

еще вариант
[vba]

Код

Sub colorize()
    Dim cell As Range
    With Application
        .ScreenUpdating = 0: .EnableEvents = 0
        On Error Resume Next
        For Each cell In [A2].Resize([counta(A:A)]).Cells
            .CutCopyMode = False
            [E:E].Find(cell, , xlValues, xlWhole).Copy
            cell.PasteSpecial xlPasteAll
        Next
        .ScreenUpdating = 1: .EnableEvents = 1
    End With
End Sub

[/vba]