Автоматизация выделения групп в Excel: экономия времени для специалистов по рекламе при составлении Семантического ядра

Sub HighlightDuplicateRows() Dim rng As Range, cell As Range Dim dict As Object Dim key As Variant Dim i As Long Dim randColor As Long Dim r As Integer, g As Integer, b As Integer ' Проверка: выделен ли ровно один столбец If Selection Is Nothing Then MsgBox "Пожалуйста, выделите столбец с данными." Exit Sub End If If Selection.Columns.Count <> 1 Then MsgBox "Пожалуйста, выделите только один столбец." Exit Sub End If ' Отключаем обновление экрана, пересчёт и события для ускорения With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With ' Создаём словарь для хранения значений и номеров строк Set dict = CreateObject("Scripting.Dictionary") Set rng = Selection ' Проходим по каждой ячейке в выделенном столбце For Each cell In rng.Cells ' Игнорируем пустые ячейки (при необходимости можно изменить логику) If Trim(cell.Value) <> "" Then key = CStr(cell.Value) If Not dict.exists(key) Then ' Используем коллекцию для хранения номеров строк, где встречается значение Set dict(key) = New Collection End If dict(key).Add cell.Row End If Next cell Randomize ' Инициализируем генератор случайных чисел ' Проходим по каждому уникальному значению For Each key In dict.keys ' Если найдено повторение (более одной строки) If dict(key).Count > 1 Then ' Генерируем случайный яркий цвет: ' Для каждого компонента (R, G, B) генерируем число от 128 до 255 r = Int(Rnd() * 128) + 128 g = Int(Rnd() * 128) + 128 b = Int(Rnd() * 128) + 128 randColor = RGB(r, g, b) ' Выделяем всю строку для каждой строки, где найдено повторяющееся значение For i = 1 To dict(key).Count ActiveSheet.Rows(dict(key)(i)).Interior.Color = randColor Next i End If Next key ' Восстанавливаем настройки приложения With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With MsgBox "Завершено выделение строк с повторяющимися значениями." End Sub

Sub HighlightDuplicateRows_Mac() Dim rng As Range, cell As Range Dim dict As Collection ' Коллекция, где в качестве ключа – значение ячейки, а элемент – коллекция номеров строк Dim keys As Collection ' Отдельная коллекция для хранения ключей (так как dict не позволяет напрямую перебирать ключи) Dim tempColl As Collection ' Вспомогательная коллекция для номеров строк Dim key As Variant Dim i As Long Dim randColor As Long Dim r As Integer, g As Integer, b As Integer Dim keyStr As String ' Проверка: выделен ли ровно один столбец If Selection Is Nothing Then MsgBox "Пожалуйста, выделите столбец с данными." Exit Sub End If If Selection.Columns.Count <> 1 Then MsgBox "Пожалуйста, выделите только один столбец." Exit Sub End If ' Отключаем обновление экрана, пересчёт и события для ускорения With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With Set dict = New Collection Set keys = New Collection Set rng = Selection ' Проходим по каждой ячейке в выделенном столбце For Each cell In rng.Cells If Trim(cell.Value) <> "" Then keyStr = CStr(cell.Value) On Error Resume Next Set tempColl = dict.Item(keyStr) If Err.Number <> 0 Then Err.Clear Set tempColl = New Collection dict.Add tempColl, keyStr keys.Add keyStr End If On Error GoTo 0 tempColl.Add cell.Row End If Next cell Randomize ' Инициализируем генератор случайных чисел ' Проходим по каждому уникальному значению For Each key In keys Set tempColl = dict.Item(key) If tempColl.Count > 1 Then ' Генерируем случайный яркий цвет (каждый компонент от 128 до 255) r = Int(Rnd() * 128) + 128 g = Int(Rnd() * 128) + 128 b = Int(Rnd() * 128) + 128 randColor = RGB(r, g, b) ' Выделяем всю строку для каждой строки с повторяющимся значением For i = 1 To tempColl.Count ActiveSheet.Rows(tempColl(i)).Interior.Color = randColor Next i End If Next key ' Восстанавливаем настройки приложения With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With MsgBox "Завершено выделение строк с повторяющимися значениями." End Sub