Excel VBA line breaks in cells slow down the execution of a merging task

Question

I must sort a table (A:W) where some cells are merged for each row: (P:Q) and (R:T). The code to perform that task works somehow, but every time I execute it Excel freezes and it takes around one minute for the task to be done.

I tested and the slow down definitely happens when .Merge Across:=True is executed. I have 2 line breaks in the merged cells and it seems that formatting is the cause behind. I have no clue how to fix and also I must stick to that format. If someone could help, it would be appreciated.

Sub Data_Sort()

Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range

Set rng1 = Worksheets("Data").Range("A2:W2", Range("A2:W2").End(xlDown)) 'whole table except the headers
Set rng2 = Worksheets("Data").Range("P2:Q2", Range("P2:Q2").End(xlDown)) 'columns P&Q with merged cells on each row
Set rng3 = Worksheets("Data").Range("R2:T2", Range("R2:T2").End(xlDown)) 'columns R,S,T with merged cells on each row

'===============
'UNMERGE CELLS
'===============

rng1.MergeCells = False 'unmerge all merged cells in the sheet

'===============
'SORT DATA
'===============

With Worksheets("Data").Sort.SortFields 'set up the criteria to sort data alphabetically starting with column A and ending with column G
    .Clear
    .Add Key:=Range("A2", Range("A2").End(xlDown)), Order:=xlAscending
    .Add Key:=Range("B2", Range("B2").End(xlDown)), Order:=xlAscending
    .Add Key:=Range("C2", Range("C2").End(xlDown)), Order:=xlAscending
    .Add Key:=Range("D2", Range("D2").End(xlDown)), Order:=xlAscending
    .Add Key:=Range("E2", Range("E2").End(xlDown)), Order:=xlAscending
    .Add Key:=Range("F2", Range("F2").End(xlDown)), Order:=xlAscending
    .Add Key:=Range("G2", Range("G2").End(xlDown)), Order:=xlAscending
End With

With Worksheets("Data").Sort 'sort data following to the setups above
    .SetRange rng1
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .Apply
End With

'===============
'MERGE & FORMAT
'===============

With rng2 'merge and format each row in the range P:Q
    .Merge Across:=True
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlCenter
    .AddIndent = True
    .IndentLevel = 1
End With

With rng3 'merge and format each row in the range R:T
    .Merge Across:=True
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlCenter
    .AddIndent = True
    .IndentLevel = 1
End With

End Sub

user_11231520 · Answer

The problem does not come from Merge but rather from the way you declare rng1, rng2 and rng3. Using .End(xlDown) means your range will go from your starting row to the last row of the sheet, rather than to the last row of your datatable. As a proof, here is the number of rows for each Range:

MsgBox ("Rng1 rows : " & rng1.Rows.Count & vbNewLine & _
        "Rng2 rows : " & rng2.Rows.Count & vbNewLine & _
        "Rng3 rows : " & rng3.Rows.Count)

Multiply that by the number of columns of each Range, it is understandable that allocation/desallocation of memory and merging/unmerging cells for such massive Ranges takes some time.

Please try this new code (feel free to remove MsgBox once tests are done):

Sub Data_Sort()

    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range

    With ThisWorkbook.Worksheets("Data")
        Set rng1 = .Range("A2", "W" & .Cells(.Rows.Count, "W").End(xlUp).Row) 'whole table except the headers
        Set rng2 = .Range("P2", "Q" & .Cells(.Rows.Count, "Q").End(xlUp).Row) 'columns P&Q with merged cells on each row
        Set rng3 = .Range("R2", "T" & .Cells(.Rows.Count, "T").End(xlUp).Row) 'columns R,S,T with merged cells on each row
    

        MsgBox ("Rng1 rows : " & rng1.Rows.Count & vbNewLine & _
                "Rng2 rows : " & rng2.Rows.Count & vbNewLine & _
                "Rng3 rows : " & rng3.Rows.Count)
                
        '===============
        'UNMERGE CELLS
        '===============

        rng1.MergeCells = False                  'unmerge all merged cells in the sheet

        '===============
        'SORT DATA
        '===============

        With .Sort.SortFields                    'set up the criteria to sort data alphabetically starting with column A and ending with column G
            .Clear
            .Add Key:=Range("A2", "A" & .Cells(.Rows.Count, "A").End(xlUp).Row), Order:=xlAscending
            .Add Key:=Range("B2", "B" & .Cells(.Rows.Count, "B").End(xlUp).Row), Order:=xlAscending
            .Add Key:=Range("C2", "C" & .Cells(.Rows.Count, "C").End(xlUp).Row), Order:=xlAscending
            .Add Key:=Range("D2", "D" & .Cells(.Rows.Count, "D").End(xlUp).Row), Order:=xlAscending
            .Add Key:=Range("E2", "E" & .Cells(.Rows.Count, "E").End(xlUp).Row), Order:=xlAscending
            .Add Key:=Range("F2", "F" & .Cells(.Rows.Count, "F").End(xlUp).Row), Order:=xlAscending
            .Add Key:=Range("G2", "G" & .Cells(.Rows.Count, "G").End(xlUp).Row), Order:=xlAscending
        End With

        With .Sort                               'sort data following to the setups above
            .SetRange rng1
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .Apply
        End With

        '===============
        'MERGE & FORMAT
        '===============

        With rng2                                'merge and format each row in the range P:Q
            .Merge Across:=True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
            .AddIndent = True
            .IndentLevel = 1
        End With

        With rng3                                'merge and format each row in the range R:T
            .Merge Across:=True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
            .AddIndent = True
            .IndentLevel = 1
        End With
    End With
End Sub

If you have a squared data table (each column ends on the same row) and nothing written below the table, a better approch would be to hold the last row in a variable lLastRow and call it everytime you need it:

Sub Data_Sort_With_UsedRange()

    Dim rng1        As Range
    Dim rng2        As Range
    Dim rng3        As Range
    Dim lLastRow    As Long

    With ThisWorkbook.Worksheets("Data")
    
        lLastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
        
        Set rng1 = .Range("A2", "W" & lLastRow)  'whole table except the headers
        Set rng2 = .Range("P2", "Q" & lLastRow)  'columns P&Q with merged cells on each row
        Set rng3 = .Range("R2", "T" & lLastRow)  'columns R,S,T with merged cells on each row
    

        MsgBox ("Rng1 rows : " & rng1.Rows.Count & vbNewLine & _
                "Rng2 rows : " & rng2.Rows.Count & vbNewLine & _
                "Rng3 rows : " & rng3.Rows.Count)
                
        '===============
        'UNMERGE CELLS
        '===============

        rng1.MergeCells = False                  'unmerge all merged cells in the sheet

        '===============
        'SORT DATA
        '===============

        With .Sort.SortFields                    'set up the criteria to sort data alphabetically starting with column A and ending with column G
            .Clear
            .Add Key:=Range("A2", "A" & lLastRow), Order:=xlAscending
            .Add Key:=Range("B2", "B" & lLastRow), Order:=xlAscending
            .Add Key:=Range("C2", "C" & lLastRow), Order:=xlAscending
            .Add Key:=Range("D2", "D" & lLastRow), Order:=xlAscending
            .Add Key:=Range("E2", "E" & lLastRow), Order:=xlAscending
            .Add Key:=Range("F2", "F" & lLastRow), Order:=xlAscending
            .Add Key:=Range("G2", "G" & lLastRow), Order:=xlAscending
        End With

        With .Sort                               'sort data following to the setups above
            .SetRange rng1
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .Apply
        End With

        '===============
        'MERGE & FORMAT
        '===============

        With rng2                                'merge and format each row in the range P:Q
            .Merge Across:=True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
            .AddIndent = True
            .IndentLevel = 1
        End With

        With rng3                                'merge and format each row in the range R:T
            .Merge Across:=True
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
            .AddIndent = True
            .IndentLevel = 1
        End With
    End With
End Sub

EDIT :

It seems range declaration was only a part of the problem. The rest of the lag was due to visual and calculation updates of the worksheet. For context, look at this Guide to efficient VBA code.

To fix it, try adding this code before calling With ThisWorkbook.Worksheets("Data"):

With Application
    .ScreenUpdating = False
    .StatusBar = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .DisplayAlerts = False
    .PrintCommunication = False
End With

And this one after End With:

With Application
    .ScreenUpdating = True
    .StatusBar = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .DisplayAlerts = True
    .PrintCommunication = True
End With

You can look at execution duration with the Timer function, using startTimer before the code and endTimer after. Total duration is displayed with MsgBox "Duration = " & endTimer - startTimer & "s".

Excel VBA line breaks in cells slow down the execution of a merging task

1 Answers