Парная подсветка дубликатов

Среди стандартных средств Microsoft Excel есть много разных способов выделить дубликаты цветом. Самый простой и быстрый - с помощью условного форматирования. Для этого достаточно выделить диапазон ячеек и выбрать на вкладке Главная - Условное форматирование - Правила выделения ячеек - Повторяющиеся значения (Home - Conditional Formatting - Highlight Cells Rules - Duplicate Values):

duplicates-coloring1.png

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

duplicates-coloring2.png

Так гораздо нагляднее, правда? Конечно, при большом количестве повторяющихся ячеек оттенки различить будет трудно, но при относительно небольшом количестве дубликатов этот способ сработает отлично.

Чтобы использовать этот макрос нажмите сочетание клавиш Alt+F11 или кнопку Visual Basic на вкладке Разработчик (Developer), вставьте новый пустой модуль через меню Insert - Module и скопируйте туда код этого макроса:

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

Теперь можно выделить любой диапазон с данными на листе и запустить наш макрос с помощью сочетания клавиш Alt+F8 или через кнопку Макросы (Macros) на вкладке Разработчик (Developer).

Ссылки по теме



ABB
18.05.2014 15:35:15
Спасибо! Как всегда здорово! А как менять цвета заливки?
21.05.2014 12:30:58
Спасибо. Как раз сегодня нужно было найти повторы в более 3000 строках. Единственное ограничение макроса: не более 54 повторов.
Ну или дорабатывать макрос самому.
28.05.2014 16:44:26
С Dictionary или Collection было бы куда короче...
31.05.2014 00:11:42
Пробовал словарь, но сильно короче не получилось, а код вышел гораздо менее понятный для начинающих.
В любом случае, буду рад вашему варианту тут в комментариях ;)
01.06.2014 00:37:33

 Sub DuplicatesColoring1()
  Set objDictDupes = CreateObject("Scripting.Dictionary" )
  Selection.Interior.ColorIndex = -4142
  i = 3
  For Each cell In Selection
    If objDictDupes.Exists(cell.Value) Then
   If objDictDupes.Item(cell.Value).Interior.ColorIndex <> -4142 Then
     cell.Interior.ColorIndex = objDictDupes.Item(cell.Value).Interior.ColorIndex
   Else
     objDictDupes.Item(cell.Value).Interior.ColorIndex = i
     cell.Interior.ColorIndex = i
     i = i + 1
   End If
    Else
   objDictDupes.Add cell.Value, cell
    End If
  Next
End Sub
Нда... короче на ОДНУ строку и код действительно не для начинающих... :D
02.06.2014 15:35:47
Вот-вот, я тоже что-то очень похожее сначала накатал, но потом подумал и исправил на более простой и понятный вариант.
Хотя на словаре должно, по идее, заметно быстрее работать на больших массивах, конечно :)
01.06.2014 21:56:32
Николай, а можно вопрос не по теме, вы вот используете SyntaxHighlighter. Я - тоже. Можете предположить, почему у меня он игнорирует символы табуляции в коде? Я использую тег <pre>.
02.06.2014 15:10:46
Денис, я ставлю <pre class="brush:vb">
Из справки нарыл :)
02.06.2014 16:00:21
Ну, это понятно :) VB он у меня подсвечивает, вот только отступы игнорирует. Получается некрасиво. Ладно, разберемся.
13.06.2014 16:30:55
Не так давно делал аналогичный макрос:
http://excelvba.ru/code/DuplicatesColors

Только мой макрос не зависнет при выделении всего листа (или, хотя бы, столбца) целиком,
и не вылетает с ошибкой, если найдено более 55 дубликатов
14.06.2014 10:38:57
Спасибо, Игорь - красивое решение.
02.07.2014 11:40:58
Данный пример только что сильно выручил ))))
Самое главное знать, что есть такая возможность в экселе, а втрое знать где лежит такая ценная информация!
Павел, огромное Вам спасибо :)!
04.07.2014 10:04:34
Не за что, Сергей! "Главное - умение пользоваться литературой", как говорил один наш хороший преподаватель в Бауманке :)
09.07.2014 18:31:17
Здравствуйте! Я тот самый начинающий самоучка в vba, хотела бы с вами проконсультироваться, как следует изменить код (мои попытки не увенчались успехом), чтобы поиск каждого следующего слова окрашивался другим цветом?
Sub Выделить_несколько_строк3()
    Dim w1 As Range
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    wb.Sheets(4).Activate
    myword = InputBox("Введите искомое слово:")
    For Each w1 In ActiveSheet.UsedRange.Cells
        If w1 <> Empty Then
            If w1 = Cells.Find(myword) Then
                w1.Select
                Selection.Interior.Color = RGB(255, 0, 0)
            End If
        End If
    Next w1
End Sub
Как то может принять, например, белый цвет за базовый? Ваш макрос, конечно, работает без проблем, но хотелось бы свой доразбирать, а спросить, что делаю не так, не у кого. Или проще бросить эту затею?!
Цикл стоит заменить на несколько иной - через findnext,
смена цвета должна происходить либо шагово (меняет код RGB на определенное число), либо в зависимости от количества. Например так:
Sub Выделить_несколько_строк3()
    Dim w1, nach As Range
    Dim redCLR, grCLR, blCLR As Byte
    Dim myword As String
    redCLR = 231    ' устанавливает счетчик красного для цвета
    grCLR = 231    ' устанавливает счетчик зеленого для цвета
    blCLR = 231    ' устанавливает счетчик синего для цвета
    Sheets(4).Activate
    Do    ' запуск цикла
        myword = InputBox("Введите искомое слово:")    ' ввод слова
        If myword = "" Then Exit Sub    ' проверка на пустоту, если да - выход из цикла
        Set nach = Cells.Find(myword)    ' устанавливает первую позицию слова
        If Not nach Is Nothing Then Set w1 = Cells.FindNext(nach) Else Exit Sub    ' если слово найдено, ищет следующую позицию, если нет, завершение алгоритма
        Do    ' запуск нового цикла
            w1.Interior.Color = RGB(redCLR, grCLR, blCLR)    ' раскраска второй найденной ячейки
            If redCLR > 0 Then    ' смена цвета
                redCLR = redCLR - 33
            Else
                redCLR = 231
                If grCLR > 0 Then
                    grCLR = grCLR - 33
                Else
                    grCLR = 231
                    If blCLR > 0 Then
                        blCLR = blCLR - 33
                    Else
                        blCLR = 231
                    End If
                End If
            End If
            Set w1 = Cells.FindNext(w1)    ' поиск следующей ячейки
        Loop While nach.Address <> w1.Address    ' повтор цикла, если адрес 1ой найденной ячейки и следующей не совпадает
    Loop While myword <> ""    ' повтор цикла, если слово не пустое
End Sub
25.07.2014 13:01:12
Как то выкладывал свое мнение (и решение) по поводу раскраски неизвестного количества ячеек в разные цвета (
Раскрасить динамический диапазон в разные цвета), но видимо это не особо кому-либо нужно. Может здесь поможет?
07.10.2014 18:10:40
Здравствуйте, подскажите, как можно выделять дубли повторяющихся слов, но порядок этих слов изменен.
Хотелось бы получить таблицу вида:
мама мыла раму
мыла мама раму
раму мыла мама
мамка мыла рамку
рамку мыла мамка
когда мама мыла раму
мама когда раму мыла
03.11.2014 15:11:52
С такими задачами лучше на Форум. Но я бы, с ходу, предложил просуммировать коды всех символов и сравнивать их друг с другом - что-то вроде контрольной суммы. Заодно еще можно длину фраз и количество слов (пробелов) сверять.
27.12.2014 10:29:38
А у меня вопрос, а возможно сделать так что бы, выделение повторяющихся ячеек(значений в ячейках) происходило с минимального числа до максимального в массиве? И вставить туда еще и замедление миллисекунд так в 250 между заполнением цветом группы дубликатов.
15.01.2015 16:50:47
Доброго дня! Подскажите, как сохранить этот макрос? Сделал все как написано - заработало. Закрыл файл и попытался запустить макрос в новом файле - нет макроса.
Заранее спасибо
24.02.2015 16:25:55
Нужно сохранять файл в формате с поддержкой макросов (XLSM). Иначе все макросы в файле умирают (о чем он, вообще-то, должен был выдать предупреждение).
И защита от макросов должна быть выключена, иначе даже работающий сохраненный в книге макрос будет заблокирован (Файл - Параметры - Центр Управления безопасностью).
24.02.2015 15:45:15
Добрый день
Подскажите пож-та
когда копирую и вставляю код макроса то
вместо Dim Dupes() 'объявляем массив для хранения дубликатов - получается Dim Dupes() '????????? ?????? ??? ???????? ??????????
Почему так происходит?
Спасибо.
24.02.2015 16:23:56
Копируете с этой страницы сайта или из другого файла Excel?
Возможно, что у вас Office изначально не английский и не русский, например французский или немецкий?
03.03.2015 14:16:20
да спасибо-вроде сейчас все норм
15.03.2015 12:56:52
Добрый день!
У меня та же проблема, что и у Михаила Никидимова. Я копировала макрос из вашего сайта и вставила в excel, но во-первых вместо русских слов стоят вопросы, во=вторых макрос так и не сработал. Excel у меня, если не ошибаюсь, стоит русский (все на русском, но не уверена что изначальная установка была на русском). Подскажите, Никоолай, что сделать, что бы заработало?
21.05.2015 17:09:42
Запоздалый ответ...при копировании текста должна быть русская раскладка, а не английская.
30.09.2015 11:58:32
хм... а у меня почему-то выдает ошибку "Run time error '9': Subscript out of range" на строку "cell.Interior.ColorIndex = i"
может кто-нибудь подсказать, как ее исправить?
02.10.2015 10:18:19
Коллеги, лучше не копировать текст макроса с вебстраницы (можно нечаянно что-нибудь лишнее зацепить или упустить), а скачать файл примера из шапки - он для этого там и есть :)
02.10.2015 15:46:38
Спасибо!
сразу не сообразил...
21.04.2016 12:09:38
Мне нужно только одним цветом.В базе десятки тысяч майлов в одном столбце.Добавляю по 500-700 каждый день и проверяю не было ли ранее их?Все работает-НО очень тормозит.Есть ли какой-то нетормозной способ такой простейшей проверки кроме указанного?
14.05.2016 19:11:56
Главная - Условное форматирование - Правила выделения ячеек - Повторяющиеся значения
13.05.2016 21:51:02
Добрый день!
Не работает макрос. :cry: У меня "не работает" даже ваш пример.
P.S. установлен Office 2013
14.05.2016 19:11:05
У вас Office не 64-разрядный, часом?
07.12.2016 14:03:25
Спасибо! Красиво работает!
14.12.2016 11:53:22
Подскажите возможно ли больше цветов использовать чем 56? Или как еще можно найти дубликаты которых будет намного больше чем 1000 штук?
15.12.2016 12:20:42
Встречный вопрос: а вы отличите больше 1000 оттенков с ходу? :)
При таком количестве повторов, мне кажется, нужен другой подход.
16.12.2016 10:23:26
я их потом смогу отсортировать по цвету, возможно и другой подход, задача заключается в том чтобы из 10 столбцов по 3-5 тыш записей найти и выделить дубликаты