VBA Excel - Merge cells in column B based on column A merge

Question

I have a routine that merges sequential cells in column A. I need to merge the cells in column B that are sequentially matching, but NOT merge across the row boundaries of the merged column A cells. My merge for column A is working as expected.

However, if the values in column B have sequential values that begin next to merged A cell and continue into the next cell, they merge across the boundary. How do I base my merger of sequentially matching B cells on the already merged A cells?

Here's how my code currently merges the row boundaries of column A's merged cells:

Example

Here's how I intend for it to look:

Example of Successful Merge

My current code:

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

Any guidance on accomplishing this would be greatly appreciated!

for starters you should turn both ScreenUpdating and DisplayAlerts back "on" by setting them back to True following Application.Calculation — Marcucciboy2
Do a check using ? cell.Offset(-1,0).MergeArea.Address to ensure that the last row in the range of the Column A cells is <= the current cell's row. Add that to your If statement. — Cyril
@Marcucciboy2 Strictly speaking, Excel resets ScreenUpdating to True automatically, but as to me I prefer to state it explicitly. — JohnyL
Thanks for the suggestion @Cyril. I added the following to my If statement, but it did not change the outcome. If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False And cell.Row <= cell.Offset(-1, -0).MergeArea.Address Then — John Miller
@JohnMiller the check involves the full "? cell.offset(-1,0).mergearea.address" which should provide a range back. you would need to determine the final row of that range, which is probably best kept as a variable (k), then your if statement includes cell.row <= k — Cyril

John Miller John Miller · Accepted Answer · 2018-09-13T17:58:43

This was difficult to solve. Once column A is merged, when merging sequentially matching cells in column B, I can check to see if the neighboring cell in column A is merged cell.Offset(0, -1).MergeCell. I can also get the first merged row j = cell.Offset(0, -1).MergeArea.Row and calculate the last merged row by taking the count of merged rows k = cell.Offset(0, -1).MergeArea.Count and setting lastmergerow = j + k -1 (subtract 1 to get the end of the MergeArea).

However, the key is to set and update variables while looping through the range. In the code below, I updated the start and end rows for the range to keep from merging past the MergeArea from the A column. This allowed me to merge sequentially matching values in column B while keeping within the MergeArea from column A.

Avoid working with merged cells whenever possible!!! But, in the rare occasion that someone needs to do this, I hope the following code helps.

My 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

VBA Excel - Merge cells in column B based on column A merge

1 Answers