Объединение ячеек при совпадении значений ячеек (другое значение строки столбца)

Question

Я хотел бы написать 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

Answer 1

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

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 & "."
                End If

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

                    With rngData.Worksheet.Range(strTopCell & ":" & 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 & ":" & strLastCell)

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

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

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

Answer 2

Редактировать Незначительное обновление для расширения диапазонов слияния и включения обновлений слияния.

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

• Сохранить в обычном модуле.
• Убедитесь, что константы (Const) стоят перед любым другим кодом в модуле.
• Рассмотрите возможность добавления защиты, чтобы она работала только с рабочим листом
  это предназначено для (см. как после кода).
• Запустите макрос из диалогового окна Alt - F8 .
• NB Как и большинство макросов, это приведет к стиранию буфера отмены 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").