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

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

Будем очень признательны за любые рекомендации по выполнению этого!


excel vba mergesort
person John Miller    schedule 06.09.2018    source источник
comment
для начала вы должны снова включить ScreenUpdating и DisplayAlerts, вернув их на True после Application.Calculation   -  person Marcucciboy2    schedule 06.09.2018
comment
Сделать чек с помощью ? cell.Offset (-1,0) .MergeArea.Address, чтобы последняя строка в диапазоне ячеек столбца A была ‹= текущей строкой ячейки. Добавьте это в свой оператор If.   -  person Cyril    schedule 06.09.2018
comment
@ Marcucciboy2 Строго говоря, Excel автоматически сбрасывает ScreenUpdating на True, но я предпочитаю указывать это явно.   -  person JohnyL    schedule 06.09.2018
comment
Спасибо за предложение @Cyril. Я добавил следующее в свой оператор If, но это не повлияло на результат. Если cell.Value = cell.Offset (1, 0) .Value And IsEmpty (cell) = False And cell.Row ‹= cell.Offset (-1, -0) .MergeArea.Address Then   -  person John Miller    schedule 06.09.2018
comment
@JohnMiller проверка включает в себя полную? cell.offset (-1,0) .mergearea.address, который должен возвращать диапазон. вам нужно будет определить последнюю строку этого диапазона, которую, вероятно, лучше всего сохранить как переменную (k), тогда ваш оператор if включает cell.row ‹= k   -  person Cyril    schedule 07.09.2018
comment
@Cyril - Итак, как мне проверить диапазон объединенных ячеек в A при объединении B? Я понимаю, что могу установить k = последняя строка объединенной ячейки в A. Но я не уверен, как ссылаться на это, поскольку я выполняю слияние в столбце B.   -  person John Miller    schedule 07.09.2018
comment
Я могу установить переменную в последнюю строку области слияния в столбце A, используя 'If cell.Offset (0, -1) .MergeCells Then k = cell.Offset (0, -1) .MergeArea. Count l = cell.Offset (0, -1) .MergeArea.Row m = l + k-1 ' Я все еще не могу заставить это работать, потому что мой оператор if (' If cell.Value = cell.Offset (1, 0) .Value And IsEmpty (cell) = False And cell.Row ‹= m Then ') не работает, потому что cell.Row не увеличивается при перемещении в следующую ячейку. ? cell.Row = 2 до и после слияния. Есть предложения, как это исправить?   -  person John Miller    schedule 11.09.2018

Ответы (1)


arrow_upward
0
arrow_downward

Это было трудно решить. После объединения столбца A при объединении последовательно совпадающих ячеек в столбце B я могу проверить, объединена ли соседняя ячейка в столбце A cell.Offset (0, -1) .MergeCell. Я также могу получить первую объединенную строку j = cell.Offset (0, -1) .MergeArea.Row и вычислить последнюю объединенную строку, взяв количество объединенных строк k = cell. Смещение (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 < lastmergerow Then
                                Range(cell, cell.Offset(1, 0)).Merge
                                bRow = bRow + 1
                            Else
                                bRow = bRow + 1
                                lrow = lastmergerow
                                If bRow > endRow Then
                                    GoTo NextSheet
                                End If
                                If bRow > 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
person John Miller    schedule 13.09.2018