Одинаковые значения excel макросы - Word и Excel - помощь в работе с программами

В данном примере напишем код макроса, который сможет автоматически найти и объединить все одинаковые ячейки в таблице Excel любой сложности.

Как объединить одинаковые ячейки в столбце используя макрос

Имеется отчет продаж в сети магазинов по целой стране. Нам нужно сделать таблицу данного отчета более читабельной. Для этого следует красиво сформатировать первый столбец, в котором содержаться названия штатов:

Мы хотим объединить все ячейки с одинаковыми значениями в столбце «Штат» (A). Это можно реализовать с помощью ручного выделения отдельных групп одинаковых значений и объединения их ячеек, воспользовавшись инструментом: «ГЛАВНАЯ»-«Выравнивание»-«Объединить и поместить в центре». Но если таблица содержит тысячи таких групп, да еще с разным количеством повторяющихся ячеек, тогда рационально написать макрос. Он сам быстро и автоматически выполнит всю работу за Вас.

Откройте редактор Visual Basic (ALT+F11):

И создайте новый модуль с помощью инструмента: «Insert»-«Module». А потом запишите в него VBA-код макроса:

Sub JoinDoubles() Dim i As Long Application.DisplayAlerts = False For i = Selection.Rows.Count To 2 Step -1 If Selection.Cells(i, 1) = Selection.Cells(i - 1, 1) Then Range(Selection.Cells(i - 1, 1), Selection.Cells(i, 1)).Merge End If Next Selection.VerticalAlignment = xlVAlignCenter Application.DisplayAlerts = True End Sub

Теперь если нам необходимо объединить ячейки с одинаковыми значениями, то выделите диапазон A1:A18 и запустите макрос выбрав инструмент: «РАЗРАБОТЧИК»-«Код»-«Макросы»-«JoinDoubles»-«Выполнить». Результат действия макроса отображен на рисунке:

В начале кода мы декларируем переменную для хранения показателей счетчика цикла. В цикле проверяем значения соседних ячеек, начиная с низа выделенного диапазона. Если ячейка содержит такое же значение значит она будет объединена.

Дополнительно в начале кода макроса устанавливаем свойство «False» для объекта «DisplayAlerts», чтобы предотвратить появления предупреждающего сообщение о попытке объединить непустые ячейки в программе Excel. В конце выполнения кода макроса обратно возвращаем свойство «True» для объекта «DisplayAlerts».

Обратите внимание! Если перед выполнением макроса выделить более одного столбца, то в результате будут объединены одинаковые значения только в первом столбце. Чтобы расширить поле действия макроса следует немного изменить его код.

Как объединить все одинаковые ячейки в любой таблице

Немного изменим структуру исходной таблицы:

На этот раз нам необходимо объединить все ячейки с одинаковыми значениями в столбце «Штат» (B) в столбце «№» (A).

Если мы хотим, чтобы действия макроса распространялось на несколько выделенных столбцов, то делаем следующее. Сначала добавим новую переменную:

Dim j As Long

Далее добавим строку с кодом начала нового цикла, который будет проходить по другим столбцам выделенного диапазона:

For j = 1 To Selection.Columns.Count

После конца, ранее созданного (внутреннего) цикла добавляем инструкцию Next для конца нового (внешнего) цикла . И соответственно сделаем код более читабельным с помощью отступов табуляции. Кроме того, для всех экземпляров объекта Cells во втором аргументе, вместо числа 1 введем переменную j (например, Selection.Cells(i, j)). Новая версия измененного кода макроса выглядит следующим образом:

Sub JoinDoubles() Dim i As Long Dim j As Long Application.DisplayAlerts = False For j = 1 To Selection.Columns.Count For i = Selection.Rows.Count To 2 Step -1 If Selection.Cells(i - 1, j) = Selection.Cells(i, j) Then Range(Selection.Cells(i - 1, j), Selection.Cells(i, j)).Merge End If Next Next Selection.VerticalAlignment = xlVAlignCenter Application.DisplayAlerts = True End Sub

Чтобы увидеть результат действия новой версии кода, выделяем всю таблицу и запускаем макрос:

Читайте также: как объединить одинаковые ячейки в строках таблицы.

Как видно на рисунке теперь макрос автоматически объединяет одинаковые значения сразу в двух столбцах.

Источник

На чтение 3 мин. Просмотров 4.1k.

Что делает макрос: Всегда хотел выделить значения дубликатов в диапазоне. Макрос в этом разделе делает именно это. Есть много ручных способов найти и выделить дубликаты — способы, включающие формулы, условное форматирование, сортировку и т.д. Тем не менее, все эти методы требуют ручной настройки и определенного уровня обслуживания по мере изменения данных.
Этот макрос упрощает задачу, что позволяет найти и выделить дубликаты в ваших данных с помощью щелчка мыши.

Содержание

Как макрос работает
Код макроса
Как этот код работает
Как использовать

Как макрос работает

Этот макрос перечисляет ячейки в целевом диапазоне, используя оператор For Each, чтобы активировать каждую ячейку по одной за раз. Затем мы используем функцию СЧЕТЕСЛИ, чтобы подсчитать, сколько раз значение в активной ячейке находится в выбранном
диапазоне. Если это число больше единицы, то формат ячейки — желтого цвета.

Код макроса

Sub VidelitDublikati()
'Шаг 1: Объявляем переменные
Dim MyRange As Range
Dim MyCell As Range
'Шаг 2: определяем целевой диапазон
Set MyRange = Selection
'Шаг 3: запускаем цикл через диапазон
For Each MyCell In MyRange
'Шаг 4: Убедить, что ячейка имеет форматирование текста
If WorksheetFunction.CountIf(MyRange, MyCell.Value) > 1 Then
MyCell.Interior.ColorIndex = 36
End If
'Шаг 5: Получаем следующую ячейку в диапазоне
Next MyCell
End Sub

Как этот код работает

На шаге 1 объявляются две переменные объекта Range, одна из которых называется MyRange для хранения всей цели диапазона, а другая называется MyCell для хранения каждой ячейки в диапазоне.
Шаг 2 заполняет переменную MyRange целевым диапазоном. В этом примере мы используем выбранный диапазон — диапазон, который был выбран в электронной таблице. Вы можете легко установить переменную MyRange для определенного диапазона, например Range («A1: Z100»). Кроме того, если ваша цель — именованный диапазон, вы можете просто ввести его имя: Range («MyNamedRange»).
Шаг 3 макрос начинает проходить по каждой ячейке в целевом диапазоне, активируя каждую ячейку.
Объект WorksheetFunction позволяет нам запускать многие из Excel функции электронных таблиц в VBA. Шаг 4 использует объект WorksheetFunction для запуска Функция СЧЕТЕСЛИ в VBA.
В этом случае мы рассчитываем, сколько раз значение активной ячейки (MyCell.Value) найдено в заданном диапазоне (MyRange). Если выражение СЧЕТЕСЛИ оценивается больше 1, макрос изменяет цвет ячейки.
Шаг 5 возвращается к следующей ячейке. После активации всех ячеек в целевом диапазоне макрос заканчивается.

Как использовать

Для реализации этого макроса, вы можете скопировать и вставить его в стандартный модуль:

Активируйте редактор Visual Basic, нажав ALT + F11.
Щелкните правой кнопкой мыши имя проекта / рабочей книги в окне проекта.
Выберите Insert➜Module.
Введите или вставьте код.

Источник

PVA

Пользователь

Сообщений: 9
Регистрация: 28.03.2013

Уважаемый Hugo, и другие форумчане!
Передо мной стоит очень много задач, которые нужно реализовать с помощью макросов, но в силу того, что не красиво каждый раз просить готовый код, я стараюсь разбираться в кодах сам, дабы в будущем их (т.е. коды) самому и создавать.
Так вот, хочу вернуться к предыдущему коду, а именно этот код я для себя дополняю где можно всякими комментариями и примечаниями, и на данный момент код выглядит вот так (с моими комментами):

Код
Private Sub CommandButton1_Click() Dim color1 As Range, arr '-задаем переменную color1 тип данных - range (т.е. как диапазон данных) (используя оператор Dim) для последующих операций со строками, а также переменную arr, которую не привязываем ни к одному типу With CreateObject("scripting.dictionary") '-создаем объект Dictionary, и работаем с ним с помощью оператора With For Each color1 In Sheets("Список").[a1].CurrentRegion.Columns(1).Cells .Item(color1.Value) = color1.Interior.Color & "\|" & color1.Interior.Pattern & "\|" & color1.Interior.PatternColor '-с помощью команды Item мы записываем в созданный объект Dictionary данные про цвет, штриховку и цвет штриховки каждой ячейки в столбце А (т.е. 1). Next Sheets("Календарь").UsedRange.Cells.Interior.Color = xlNone '-обнуляем все цвета, перед тем как создать новые. Т.е. каждый раз при обновлении - мы заново сверяем и закрашиваем ячейки. For Each color1 In Sheets("Календарь").UsedRange.Cells If .exists(color1.Value) Then '-проверяем условие существования на листе "Calendar" точно таких же дат, как есть на листе "Action Plan" arr = Split(.Item(color1.Value), "\|") color1.Interior.Color = arr(0) '-назначаем цвет фона ячейки color1.Interior.Pattern = arr(1) '-назначаем формат штриховки ячейки color1.Interior.PatternColor = arr(2) '-назначаем цвет штриховки ячейки End If Next End With End Sub

Код

Private Sub CommandButton1_Click()
    Dim color1 As Range, arr    '-задаем переменную color1 тип данных - range (т.е. как диапазон данных) (используя оператор Dim) для последующих операций со строками, а также переменную arr, которую не привязываем ни к одному типу
    
    With CreateObject("scripting.dictionary") '-создаем объект Dictionary, и работаем с ним с помощью оператора With
        For Each color1 In Sheets("Список").[a1].CurrentRegion.Columns(1).Cells
            .Item(color1.Value) = color1.Interior.Color & "|" & color1.Interior.Pattern & "|" & color1.Interior.PatternColor '-с помощью команды Item мы записываем в созданный объект Dictionary данные про цвет, штриховку и цвет штриховки каждой ячейки в столбце А (т.е. 1).
        Next

        Sheets("Календарь").UsedRange.Cells.Interior.Color = xlNone '-обнуляем все цвета, перед тем как создать новые. Т.е. каждый раз при обновлении - мы заново сверяем и закрашиваем ячейки.

        For Each color1 In Sheets("Календарь").UsedRange.Cells
            If .exists(color1.Value) Then '-проверяем условие существования на листе "Calendar" точно таких же дат, как есть на листе "Action Plan"
                arr = Split(.Item(color1.Value), "|")
                color1.Interior.Color = arr(0) '-назначаем цвет фона ячейки
                color1.Interior.Pattern = arr(1) '-назначаем формат штриховки ячейки
                color1.Interior.PatternColor = arr(2) '-назначаем цвет штриховки ячейки
            End If
        Next
    End With
End Sub

Так вот, прошу вас, форумчане проверить мои комментарии, все ли команды я правильно расшифровываю?
Кроме этого я не могу логически для себя понять вот эту строку:

Код
arr = Split(.Item(color1.Value), "\|")

Т.е. зачем мы переменной arr присваиваем что-то? И соответственно потом в дальнейшем используем эту переменную arr в тем строках, где назначаем цвет ячейки и т.д. (не понимаю команду split(.Item(color1.Value), «|»))
Причем в следующих строках с использованием arr мы в скобках пишем разные цифры (0) (1) (2), зачем?

P.S. Простите за дилетантизм, и прошу хотя бы ссылку на простейшее описание (хелп от VBA и прочие официальные описания не дали мне ответ, а простые формы описания не нашел).

Заранее спасибо большое за ответ (-ы).
Владимир.

Источник

Поиск повторяющихся значений (дубликатов) в одном из столбцов таблицы Excel и выделение их цветом заливки с помощью кода VBA.

Поиск дубликатов в столбце

Чаще всего повторяющиеся значения ищут в первом столбце таблицы, поэтому процедуру поиска дубликатов в VBA Excel рассмотрим именно на нем:

Sub DuplicateSearch()

Dim ps As Long, myRange As Range, i1 As Long, i2 As Long

‘Определяем номер последней строки таблицы

ps = Cells(1, 1).CurrentRegion.Rows.Count

‘Нет смысла искать дубликаты в таблице, состоящей из одной строки

If ps > 1 Then

‘Присваиваем объектной переменной ссылку на исследуемый столбец

Set myRange = Range(Cells(1, 1), Cells(ps, 1))

With myRange

‘Очищаем ячейки столбца от предыдущих закрашиваний

.Interior.Color = xlNone

For i1 = 1 To ps — 1

For i2 = i1 + 1 To ps

If .Cells(i1) = .Cells(i2) Then

‘Если значения сравниваемых ячеек совпадают,

‘обеим присваиваем новый цвет заливки

.Cells(i1).Interior.Color = 6740479

.Cells(i2).Interior.Color = 6740479

End If

End With

End If

End Sub

После ручного исправления или удаления повторяющихся значений, запускаем процедуру DuplicateSearch вновь, чтобы очистить от заливки ячейки столбца с уникальными значениями и заново выделить оставшиеся дубликаты.

Чтобы найти повторы в другом столбце, замените номер столбца в параметрах свойства Cells (в трех местах процедуры DuplicateSearch).

Константы для заливки

Для указания цвета заливки для ячеек с повторяющимися значениями вместо числового значения цвета можно использовать предопределенные константы:

Предопределенная константа	Наименование цвета
vbBlack	Черный
vbBlue	Голубой
vbCyan	Бирюзовый
vbGreen	Зеленый
vbMagenta	Пурпурный
vbRed	Красный
vbWhite	Белый
vbYellow	Желтый

Источник

0 / 0 / 0

Регистрация: 24.05.2008

Сообщений: 4

19.01.2009, 15:57. Показов 40085. Ответов 8

Регистрация: 19.01.2009
Сообщения: 2
Репутация:10
поиск макросом дубликатов в таблице эксель
Приветствую

появилась необходимость поиска повторяющихся улиц с номерами домов в таблице эксель с помощью макроса

Итак есть столбец «улица», рядом столбец «дом». Есть еще другие Столбцы в которых есть информация.
Если есть 2 записи в которых улица и номер дома идентичны, то подсветить красным цветом чтобы менеджер мог удалить лишнюю запись.
Так как дубликатов быть не должно.
Таблица состоит из 20 000! записей(строк)

Как можно было бы организовать алгоритм обхода так, чтобы это работало максимально производительно(быстро)

во вложении к посту
тестовая база на 6000 записей + мой макрос который жутко вешает EXCEL

32 / 32 / 4

Регистрация: 29.12.2008

Сообщений: 75

19.01.2009, 20:01

Пока не шочу слишком глубоко вдаваться в идею самого макроса, но думаю, гораздо удобнее сначала отсортировать таблицу excell по улицам в алфавитном порядке (макрос для этого можно не писать в ручную, а воспользоваться командой «Запись макроса» и выбрать сортировку по возрастанию или убыванию). В отсортированной таблице поиск повторяющихся элементов не должен занять много времени, особенно если воспользоваться «бинарным поиском».

Примечание:
Для сохранения целостности табличных данных, перед сортироукой таблицу лучше выделить. Далее воспользоваться командой Данные -> Сортировка.

loter

2 / 2 / 0

Регистрация: 16.01.2009

Сообщений: 11

20.01.2009, 22:43

я в макросах не сильна, но эту задачу можно решить еще вот так:

Visual Basic

Sub check()
 
a = InputBox("введите количетсво записей")
 
For x = 3 To a
    If Cells(x, 4).Value = 1 Then GoTo d
    For y = x + 1 To a
        If Cells(x, 1).Value = Cells(y, 1).Value And Cells(x, 2).Value = Cells(y, 2).Value Then '
            'Cells(у, 1).Select
            'Selection.Interior.ColorIndex = 3
            Cells(y, 4).Value = 1
        End If
    Next y
d:
Next x
End Sub

по такому алгоритму у меня расчет занял 22 минуты 12 секунд. не знаю быстрее это или медленее чем у Вас, но мало ли… м.б. пригодится.

если доступна сотировка, то есть более быстрый и простой механизм, только он делается не макросом, а формулой. сортируем сначала по а, затем по б и в пустой столбец во вторую строку забиваем формулу «=если((A2=A3)*И(B2=B3);1;»»)». растягиваем формулу до конца.
в результате получаем единички напротив повторов.
чисто теоретически все это можно загнать в макрос

32 / 32 / 4

Регистрация: 29.12.2008

Сообщений: 75

21.01.2009, 18:19

Loter. Ты прав на все 100%. Однако вся прелесть макросов — это автоматизация твоих действий.

Представь, что тебе каждый раз после ввода новых данных необходимо будет сначала отсортировать таблицу, потом выбрать специальный столбец, куда можно будет ввести предложенную тобой формулу с ЕСЛИ, растянуть ее (на несколько тысяч записей). Потом найти все строки, в которых твоя формула дает 1 и, наконец, выделив их, залить красным цветом.

У-Ф-Ф-Ф… Даже рука устала писать. Гораздо проще все это проделать одним кликом по кнопке, который присвоен специальный макрос.

Кстати.
Твой вариант с перебором ячеек хорош, но требует много времени для большого количества записей, в то время как в Excell уже встроен достаточно быстрый механизм сортировки.

loter

2 / 2 / 0

Регистрация: 16.01.2009

Сообщений: 11

22.01.2009, 18:01

хм….

Visual Basic

Sub nnn()
 
'проводим сортировку примерно так
    Columns("A:B").Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortTextAsNumbers
        
'находим последнюю запись
    Range("A2").Select
    Selection.End(xlDown).Select
    x = ActiveCell.Row
    
'забиваем формулу если
    Cells(x, 100).Select
    ActiveCell.FormulaR1C1 = _
        "=IF((RC[-99]=R[1]C[-99])*AND(RC[-98]=R[1]C[-98]),""повтор"","""")"
    Selection.Copy
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
 
'заливаем ячейки
    For y = 1 To x
        If Cells(y, 100).Value = "повтор" Then
            Cells(y, 1).Select
            Selection.Interior.ColorIndex = 3
        End If
    Next y
    
'и фильтруем по повторам
    Columns("CV:CV").Select
    'Selection.AutoFilter
    Selection.AutoFilter Field:=1, Criteria1:="повтор"
 
'поднимаемся вверх чтобы пользователь всего этого не видел
    Selection.End(xlUp).Select
    Selection.End(xlToLeft).Select
End Sub

на базу в 6000 заняло меньше 5 секунд
всё это дело можно завязать на сочетание клавиш типа ctrl+w или конпку

maximus09

32 / 32 / 4

Регистрация: 29.12.2008

Сообщений: 75

23.01.2009, 17:57

Не знаю как bloogrox, а я результатом в общем и целом удовлетворен.

Единственное, на что нужно обратить внимание — это то, что сейчас программа использует дополнительный столбец книги Excell для того чтобы ввести формулу

Visual Basic

1	IF((RC[-99]=R[1]C[-99])*AND(RC[-98]=R[1]C[-98]),""повтор"","""")"

Это не всегда хорошо. Поиск можно осуществить простым перебором ячеек, не выводя никакой дополнительной информации на листы книги Excell.

2 / 2 / 0

Регистрация: 16.01.2009

Сообщений: 11

23.01.2009, 20:16

maximus09, а о каких встроенных механизмах сортировки ты говорил?

32 / 32 / 4

Регистрация: 29.12.2008

Сообщений: 75

23.01.2009, 20:39

Почитай мое первое сообщение. Там найдешь такие слова:

(макрос для этого можно не писать в ручную, а воспользоваться командой «Запись макроса» и выбрать сортировку по возрастанию или убыванию). В отсортированной таблице поиск повторяющихся элементов не должен занять много времени, особенно если воспользоваться «бинарным поиском».

Если перед выбором команды Данные -> Сортировка выбрать команду Сервис ->Макрос->Начать запись, а после того, как сортировка выполнится

вручную

остановить запись макроса, то Excell автоматически сама создаст макрос сортировки. Программисту останется только его немножко подправить под свои нужды и включить то, что получится в итоге, в текст программы поиска повторяющихся элементов.

Более подробно об описанном здесь механизме программирования можно прочитать в книге
А.Ю. Гарнаев Самоучитель VBA. — СПб.: БХВ-Петербург, 2002.

Кстати, там данный пример ручной с сортировкой описан в подробностях (что, какие опции в окне параметров сортировки нужно выбирать, зачем нужно выделять всю таблицу прежде чем производить сортировку и т.п.). Очень рекомендую книгу. Сам учился по ней. Но, стоит сказать, что она целиком посвящена VBA в Excell.

2 / 2 / 0

Регистрация: 16.01.2009

Сообщений: 11

24.01.2009, 07:03

спасибо. книжку посмотрю.

IT_Exp Эксперт 87844 / 49110 / 22898 Регистрация: 17.06.2006 Сообщений: 92,604	24.01.2009, 07:03
9

Источник