Блог

Я хотел бы написать Excel vba для объединения ячеек в соответствии с их значениями и ссылочной ячейкой в другом столбце. Как на прилагаемом рисунке. У меня более 18000 строк со многими вариациями. Все значения в строке приведены в порядок.

введите описание изображения здесь

Это код, на основе которого я создал свой VBA

 Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False 
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("B2:C10") 
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then 
Range(cell, cell.Offset(1, 0)).Merge
        GoTo MergeAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
  

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

Объедините вертикально смежные ячейки с равными значениями.

• Сохраните в обычном модуле.
• Убедитесь, что константы ( Const ) предшествуют любому другому коду в модуле.
• Рассмотрите возможность добавления защиты, чтобы убедиться, что это выполняется только на рабочем листе, для которого
  оно предназначено (смотрите, как это сделать после кода).
• Запустите макрос из Alt—F8 диалогового окна макроса.
• ПРИМЕЧАНИЕ Как и большинство макросов, это приведет к удалению буфера отмены Excel.
  Это нельзя отменить с помощью Ctrl—Z. (Единственные варианты — вернуться к последнему сохраненному
  или вручную отредактировать так, как это было раньше.)

Копировать / вставить

 Private Const LastCol = 20
Private Const LastRow = 20

Public Sub Merge_Cells()
    Dim r As Range
    Dim s As Range
    Dim l As Range
    Dim c As Long
    Dim v As Variant
    
    For c = 1 To LastCol
        Set s = Nothing
        Set l = Nothing
        For Each r In Range(Cells(1, c), Cells(LastRow, c))
            v = r.MergeArea(1, 1).Value
            If v = vbNullString Then
                DoMerge s, l
                Set s = Nothing
                Set l = Nothing
            ElseIf s Is Nothing Then
                Set s = r
            ElseIf s.Value <> v Then
                DoMerge s, l
                Set s = r
                Set l = Nothing
            Else
                Set l = r
            End If
        Next r
        DoMerge s, l
    Next c
End Sub

Private Sub DoMerge(ByRef s As Range, ByRef l As Range)
    If s Is Nothing Then Exit Sub
    If l Is Nothing Then Set l = s
    Application.DisplayAlerts = False
    With Range(s, l)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Merge
    End With
    Application.DisplayAlerts = True
End Sub
  

Рассмотрим возможность поиска последнего столбца и последней строки программно.

Если слияние должно начаться после строки 1:

 For Each r In Range(Cells(1, c), Cells(LastRow, c))
                          ^
  

• Измените 1 на правильный номер строки или замените добавленной const переменной.

Для защиты других листов используйте название вкладки (рекомендуется сначала переименовать вкладку):

 For Each r In Worksheets(TabName).Range(Cells(1, c), Cells(LastRow, c))
              ^^^^^^^^^^^^^^^^^^^^
  

• Внесите эту правку в ту же строку, что и правка начальной строки.
• И добавьте Private Const TabName = "The Merge Tabs Name" ' Spaces ok
  в верхнюю часть модуля с другими Const (константами).
• Или поместите имя непосредственно в код: Worksheets("The Merge Tabs Name") .

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

 Public Sub MergeRange()
    Dim rngData As Range, lngRow As Long, lngCol As Long, strTopCell As String
    Dim strBottomCell As String, strThisValue As String, strNextValue As String
    Dim strThisMergeArea As String, strNextMergeArea As String

    Set rngData = Selection

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    With rngData
        For lngCol = 1 To .Columns.Count
            strTopCell = ""

            For lngRow = 1 To .Rows.Count
                If strTopCell = "" Then strTopCell = .Cells(lngRow, lngCol).Address

                strThisValue = .Cells(lngRow, lngCol)
                strNextValue = .Cells(lngRow   1, lngCol)

                If lngCol > 1 Then
                    strThisMergeArea = .Cells(lngRow, lngCol - 1).MergeArea.Address
                    strNextMergeArea = .Cells(lngRow   1, lngCol - 1).MergeArea.Address

                    If strThisMergeArea <> strNextMergeArea Then strNextValue = strThisValue amp; "."
                End If

                If strNextValue <> strThisValue Or lngRow = .Rows.Count Then
                    strBottomCell = .Cells(lngRow, lngCol).Address

                    With rngData.Worksheet.Range(strTopCell amp; ":" amp; strBottomCell)
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .MergeCells = True
                    End With

                    strTopCell = .Cells(lngRow   1, lngCol).Address
                End If
            Next
        Next
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
  

В этом есть один трюк, который можно изменить, и он заключается в том, что он также будет группироваться на основе предыдущего столбца. Вы можете увидеть пример того, о чем я говорю, в ячейке C19 …

… выяснилось, что в предыдущем столбце была группировка, которая остановилась в этот момент, следовательно, 1 не переносится и не группируется в следующий лот, он останавливается и группируется там. Я надеюсь, что это имеет смысл, и я надеюсь, что это дает вам то, что вам нужно.

Другое дело, этот код здесь попытается удалить все ваши ранее объединенные данные.

 Public Sub DeMergeRange()
    Dim rngData As Range, lngRow As Long, lngCol As Long, objCell As Range
    Dim objMergeArea As Range, strMergeRange As String, strFirstCell As String
    Dim strLastCell As String, objDestRange As Range

    Set rngData = Selection

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    With rngData
        For lngCol = 1 To .Columns.Count
            For lngRow = 1 To .Rows.Count
                Set objCell = .Cells(lngRow, lngCol)

                If objCell.Areas(1).MergeArea.Cells.Count > 1 Then
                    strMergeRange = objCell.Areas(1).MergeArea.Address

                    objCell.MergeCells = False

                    strFirstCell = Split(strMergeRange, ":")(0)
                    strLastCell = Split(strMergeRange, ":")(1)

                    Set objDestRange = .Worksheet.Range(.Worksheet.Range(strFirstCell).Offset(1, 0).Address amp; ":" amp; strLastCell)

                    .Worksheet.Range(strFirstCell).Copy objDestRange
                End If
            Next
        Next
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
  

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