Объединить одинаковые ячейки в excel vba

В данном примере напишем код макроса, который сможет автоматически найти и объединить все одинаковые ячейки в таблице 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


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

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

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

уважаемые!вечер добрый!

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

Например, есть 2 столбца
Значения в столбце 1 марка машины:
    А
1 Ауди
2 БМВ
3 Лексус
4 Тойота
5 Митсубиси
6 Ауди

Значения в столбце 2 — модель марки машины
   А                      В
1 Ауди               Q7
2 БМВ                x5
3 Лексус            RC
4 Тойота            Corolla
5 Митсубиси     Outlander
6 Ауди                TT

нужен макрос, чтобы при поиске одинаковых значений, он объединял в данном случае две строки (1 и 6) и по столбцу В формировались напротив этого значения две строки (1 — Q7, 2 — ТТ)

Вот так:
   А                      В
1 Ауди               Q7
                         TT
2 БМВ                x5
3 Лексус            RC
4 Тойота            Corolla
5 Митсубиси     Outlander

спасибо за помощь!!

Option Explicit
Option Base 1
'123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789

Sub Merge_by_Rows() ' Без форматирования границ
  Dim i As Integer, j As Integer, cnt As Integer
  Dim arr() As Variant, s As String
  
  With ActiveSheet.UsedRange ' Кол-во столбцов определяется по 1-й строке
    arr = Range(Cells(1, 1), Cells(.Rows.Count + 1, Range("A1").End(xlToRight).Column))
  End With
  
  cnt = 1: s = get_Row(arr, cnt)
  For i = LBound(arr, 1) + 1 To UBound(arr, 1)
    If get_Row(arr, i) <> s Then
      For j = LBound(arr, 2) To UBound(arr, 2)
        With ActiveSheet.Range(Cells(cnt, j), Cells(i - 1, j)).Offset(, UBound(arr, 2))
          .Merge
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
          .Value = arr(cnt, j)
        End With
      Next j
      cnt = i: s = get_Row(arr, cnt)
    End If
  Next i
End Sub

Function get_Row(ByVal arr As Variant, ByVal num_Row As Integer) As String
  Dim j As Integer
  
  For j = LBound(arr, 2) To UBound(arr, 2)
    get_Row = WorksheetFunction.Trim(get_Row & " " & arr(num_Row, j))
  Next j
End Function

Процедуру выполнять на активном листе.