Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос для выделения дубликатов разными цветами, Помощь в корректировке макроса
 
#1
27.10.2023 09:26:56
Добрый день, Форумчане!
Прошу оказать помощь в корректировке макроса, найденного на просторах сети.
Данный макрос - замечательный инструмент для решения вопроса с выделением дубликатов разными цветами.
Но имеется недостаток: на один цвет заливки попадают разные повторяющиеся значения ячеек.
Файл во вложении (цвет заливки в фильтре 5-й сверху).
Спасибо!  
 
 
 
#2
27.10.2023 09:38:23
Цитата
sdv62 написал:
оказать помощь в корректировке макроса,
отличная идея, но для корректировки макроса
во-первых нужен сам макрос (обьект корректировки), а в xlsx-файлах макросы не живут
во вторых для корректировки макроса нужно понимать что вас не устроило в его работе
в-третьих не плохо бы понимать задачу, как по-вашему отмечать одинаковые значения?
сосредоточтесь и... попытка №2.
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#3
27.10.2023 10:04:06
Добрый день, Игорь!
Спасибо за внимание к просьбе.
Макрос:
Sub ВыделитьДубликатыРазнымиЦветами()
On Error Resume Next
' массив цветов, используемых для заливки ячеек-дубликатов
Colors = Array(12900829, 15849925, 14408946, 14610923, 15986394, 14281213, 14277081, _
9944516, 14994616, 12040422, 12379352, 15921906, 14336204, 15261367, 14281213)
Dim coll As New Collection, dupes As New Collection, _
cols As New Collection, ra As Range, cell As Range, n&
Err.Clear: Set ra = Intersect(Selection, ActiveSheet.UsedRange)
If Err Then Exit Sub
ra.Interior.ColorIndex = xlColorIndexNone: Application.ScreenUpdating = False
For Each cell In ra.Cells ' запонимаем значение дубликатов в коллекции dupes
Err.Clear: If Len(Trim(cell)) Then coll.Add CStr(cell.Value), CStr(cell.Value)
If Err Then dupes.Add CStr(cell.Value), CStr(cell.Value)
Next cell
For i& = 1 To dupes.Count ' заполняем коллекцию cols цветами для разных дубликатов
n = n Mod (UBound(Colors) + 1): cols.Add Colors(n), dupes(i): n = n + 1
Next
For Each cell In ra.Cells ' окрашиваем ячейки, если для её значения назначен цвет
cell.Interior.color = cols(CStr(cell.Value))
Next cell
Application.ScreenUpdating = True
End Sub

Задача: корректное выделение дубликатов значений в ячейках разными цветами))))
Проблема: одним цветом выделяются ячейки с разными значениями дублей. Видно при сортировке значений ячеек по цвету 5-му сверху (розовый), выделены одним цветом ячейки с повторяющимися значениями - буквы "е" и "м".
Изменено: sdv62 - 27.10.2023 10:04:43
 
 
 
#4
27.10.2023 10:07:26
sdv62, здравствуйте
    Посмотрите пример тут: Готовые решения. Цветовая карта (ColorMap). Как выделить ячейки разными цветами по типам данных

Алгоритм:
    Собираем дубли в словарь со значениями в качестве ключей и адресами ячеек значений в качестве значений словаря по ключу.
    После этого красим в цикле каждое значение словаря (адреса, передавая их в Range, но не более строки 255 символов) в очередной цвет. Цвета лучше создать заранее (или генерировать по алгоритму) — чтобы они были визуально отличными.
    Цветов должно быть не меньше, чем ключей в словаре или же придётся красить по кругу и тогда у вас для разных дублей будут одинаковые цвета.

Цитата
Ігор Гончаренко: во-первых нужен сам макрос
его нет, согласен
Цитата
Ігор Гончаренко: во вторых для корректировки макроса нужно понимать что вас не устроило в его работе
Цитата
sdv62: имеется недостаток: на один цвет заливки попадают разные повторяющиеся значения ячеек
Цитата
Ігор Гончаренко написал:
в-третьих не плохо бы понимать задачу, как по-вашему отмечать одинаковые значения?
разными [визуально отличимыми и, по возможности, приятными для глаза] цветами
Изменено: Jack Famous - 27.10.2023 10:07:57
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#5
27.10.2023 10:38:15
Добрый день, Jack Famous!
Спасибо за обратную связь!
Рассмотрю Ваш вариант решения задачи с выделением дубликатов значений ячеек разными цветами.
 
 
 
#6
27.10.2023 11:02:46
Код
Sub FillAA()
  Const dc& = 17
  Dim a, c&, c0&, c1&, d, r&
  Set d = CreateObject("Scripting.Dictionary")
  c = RGB(200, 200, 200): c0 = xlNone
  a = Range(Cells(1, 2), Cells(Rows.Count, 1).End(xlUp))
  For r = 2 To UBound(a)
    If d.exists(a(r, 1)) Then
      c1 = d(a(r, 1))
      If c1 < 0 Then
        c = c + dc: d(a(r, 1)) = c: a(-c1, 2) = c: a(r, 2) = c
      Else
        a(r, 2) = c1
      End If
    Else
      d(a(r, 1)) = -r: a(r, 2) = c0
    End If
  Next
  Cells(1).Resize(UBound(a), UBound(a, 2)) = a
  For r = 2 To UBound(a)
    Cells(r, 1).Interior.Color = a(r, 2)
  Next
End Sub
в колонке В указано каким цветом залита ячейка справа, отрицательное значение - это ячейки без пары (и как результат - без заливки)
Изменено: Ігор Гончаренко - 27.10.2023 11:16:56
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#7
27.10.2023 11:12:42
Игорь!
Спасибо!
Всё работает на отлично!
Пожалуйста, подскажите, как сделать, чтобы код цвета не выводил?
 
 
 
#8
27.10.2023 11:15:01
Игорь!
Возможно к Вам обращаться по возникающим вопросам в процессе использования Excelя в будущем?
 
 
 
#9
27.10.2023 11:19:59
чтобы цвет не выводить
вместо
Код
Cells(1).Resize(UBound(a), UBound(a, 2)) = a

напишите
Код
Cells(1).Resize(UBound(a), 1) = a

обращайтесь)
Изменено: Ігор Гончаренко - 27.10.2023 11:20:49
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#10
27.10.2023 11:23:09
Игорь!
Огромное спасибо!)
 
 
 
Страницы: 1
Наверх