VBA Excel - объединение ячеек в столбце B на основе слияния столбца A

Question

У меня есть подпрограмма, которая объединяет последовательные ячейки в столбце A. Мне нужно объединить ячейки в столбце B, которые последовательно совпадают, но НЕ объединяются через границы строк объединенных ячеек столбца A. Мое слияние для столбца А работает как ожидалось.

Однако, если значения в столбце B имеют последовательные значения, которые начинаются рядом с объединенной ячейкой A и продолжаются в следующей ячейке, они объединяются через границу. Как я могу основать свое слияние последовательно совпадающих B-ячеек с уже слитыми A-ячейками?

Вот как мой код в настоящее время объединяет границы строк объединенных ячеек столбца A:

Вот как я собираюсь выглядеть так:

Мой текущий код:

Sub MergeV()
    ' Merge Administration and Category where sequentional matching rows exist

    ' Turn off screen updating
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim Current As Worksheet
    Dim lrow As Long

    For Each Current In ActiveWorkbook.Worksheets
        lrow = Cells(Rows.Count, 1).End(xlUp).Row
        Set rngMerge = Current.Range("A2:B" & lrow)

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

    Next Current

    ' Turn screen updating back on
    Application.Calculation = xlCalculationAutomatic

End Sub

Любое руководство по выполнению этого будет с благодарностью!

Answer 1

Это было трудно решить. После объединения столбца A при объединении последовательно совпадающих ячеек в столбце B можно проверить, объединена ли соседняя ячейка в столбце * cell.Offset (0, -1) .MergeCell . Я также могу получить первую объединенную строку j = cell.Offset (0, -1) .MergeArea.Row и рассчитать последнюю объединенную строку, взяв количество объединенных строк k = cell.Offset (0, -1) .MergeArea.Count и установка lastmergerow = j + k -1 (вычтите 1, чтобы получить конец MergeArea).

Однако ключ заключается в том, чтобы устанавливать и обновлять переменные во время циклического перемещения по диапазону. В приведенном ниже коде я обновил начальную и конечную строки для диапазона, чтобы избежать слияния после MergeArea из столбца A. Это позволило мне объединить последовательно совпадающие значения в столбце B, оставаясь в пределах MergeArea из столбца A.

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

Мой FinalCode:

    Sub MergeB()
    ' Merge Category (Column B) where sequentially matching rows exist while staying within the range of merged cells in Administration (Column A)
    ' Turn off screen updating
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Dim Current As Worksheet
    Dim lrow As Long
    Dim k As Long
    Dim j As Long
    Dim bRow As Long
    Dim endRow As Long
        For Each Current In ActiveWorkbook.Worksheets
        bRow = 2
        lrow = Cells(Rows.Count, 2).End(xlUp).Row
        endRow = Cells(Rows.Count, 2).End(xlUp).Row
    MergeAgain:
        Set rngMerge = Current.Range("B" & bRow & ":B" & lrow)
                    For Each cell In rngMerge
                    If cell.Offset(0, -1).MergeCells Then
                        k = cell.Offset(0, -1).MergeArea.Count
                        j = cell.Offset(0, -1).MergeArea.Row
                        lastmergerow = j + k - 1
                        m = k - 1
                    End If
                    Dim i As Integer
                        For i = 1 To m
                            If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False And bRow &lt lastmergerow Then
                                Range(cell, cell.Offset(1, 0)).Merge
                                bRow = bRow + 1
                            Else
                                bRow = bRow + 1
                                lrow = lastmergerow
                                If bRow &gt endRow Then
                                    GoTo NextSheet
                                End If
                                If bRow &gt lrow Then
                                    lrow = endRow
                                End If
                                GoTo MergeAgain
                            End If
                        Next i
                                bRow = lastmergerow + 1
                                lrow = endRow
                                GoTo MergeAgain
                    Next
    NextSheet:
                Next Current
    ' Turn screen updating back on
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Call AutoFit
    End Sub