Макрос для объединения повторяющихся ячеек в таблице Excel

В данном практическом примере мы напишем и пошагово разберем принцип действия VBA кода макроса для автоматического объединения повторяющихся ячеек в таблице.

Как объединить все повторяющиеся ячейки в строке

У нас иметься квартальный отчет, сформированный по отделам, как показано ниже на рисунке:

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

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

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

Sub MergeDoubles() Dim i As Long Application.DisplayAlerts = False For i = Selection.Columns.Count To 2 Step -1 If Selection.Cells(1, i) = Selection.Cells(1, i - 1) Then Range(Selection.Cells(1, i - 1), Selection.Cells(1, i)).Merge End If Next Selection.HorizontalAlignment = xlHAlignCenter Application.DisplayAlerts = True End Sub

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

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

Так же мы еще воспользуемся объектом HorizontalAlignment, чтобы выровнять текст в объединенных ячейках по центру устанавливаем ему свойство xlHAlignCenter.

Обратите внимание на то, что наш макрос пока еще не умеет работать более чем с одной строкой. Сколько строк не выделяй он все равно объединяет повторяющиеся значения только в первой строке.

Как объединить все повторяющиеся ячейки одновременно

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

Dim j As Long

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

For j = 1 To Selection.Rows.Count

После инструкции конца первого цикла добавляем новую строку с инструкцией конца для второго:

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

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

А теперь выделите диапазон B1:L12 и запустите макрос с уже новой версией кода:

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