Merge Multiple Rows in VBA

Question

I'm trying to create a simple sub-routine which will merge multiple rows if cells in column A contain the same numerical data.

Option Explicit

Sub MergeRows()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim lastRow As Long
Dim i As Long

lastRow = ThisWorkbook.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row

For i = 1 To lastRow

    
    If ThisWorkbook.Worksheets(1).Cells(i, 1).Value = _
    ThisWorkbook.Worksheets(1).Cells(i + 1, 1).Value Then
    ThisWorkbook.Worksheets(1).Range(ThisWorkbook.Worksheets(1) _
    .Cells(i, 1), ThisWorkbook.Worksheets(1).Cells(i + 1, 1)).Merge
    
    Else
    
    End If
    
Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

The code above only merges 2 lines at a time, so if there were three lines with the same value, it would merge two rows, then leave the remainder in a row to itself.

Try looping backwards For i = lastRow To 1 Step -1

cybernetic.nomad
– cybernetic.nomad

2021-06-17 15:51:33 +00:00
Commented Jun 17, 2021 at 15:51 — cybernetic.nomad
– cybernetic.nomad, Commented Jun 17, 2021 at 15:51

Toddleson · Accepted Answer · 2021-06-17 16:01:37Z

I added a While Loop that continues to check adjacent cells for the same value until it finds something different. I also added a check in your first If statement that ensures the value it is comparing against is not a blank value.

To make things easier to read I also moved the sheet reference into a With block, so it is not repeated unnecessarily throughout the code.

Option Explicit

Sub MergeRows()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim lastRow As Long
Dim i As Long, r As Long

With ThisWorkbook.Worksheets(1)

    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    
    For i = 1 To lastRow
    
        If .Cells(i, 1).Value <> "" _
        And .Cells(i, 1).Value = .Cells(i + 1, 1).Value _
        Then
            r = 1
            While .Cells(i + r, 1) = .Cells(i, 1).Value
                r = r + 1
            Wend
            .Cells(i, 1).Resize(r).Merge
        Else
        
        End If
    
    Next i
End With

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Side note: you can save on iterations by adding a line i = i + r directly after the .Merge to advance the loop to the next non-merged cell.

Collectives™ on Stack Overflow

Merge Multiple Rows in VBA

1 Answer 1

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

Comments

Your Answer

Sign up or log in

Post as a guest

Related