单元格中的 Excel VBA 换行会减慢合并任务的执行速度

Question

我必须对表格 (A:W) 进行排序，其中每行合并了一些单元格：(P:Q) 和 (R:T)。执行该任务的代码以某种方式工作，但每次我执行它时 Excel 都会冻结，并且需要大约一分钟才能完成任务。

我测试过，当执行 .Merge Across:=True 时，速度肯定会变慢。我在合并的单元格中有 2 个换行符，似乎格式化是背后的原因。我不知道如何解决，而且我必须坚持这种格式。如果有人可以提供帮助，将不胜感激。

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

Answer 1

问题不在于Merge，而在于您声明rng1、rng2 和rng3 的方式。使用.End(xlDown) 意味着您的范围将从您的起始行到工作表的最后一行，而不是到数据表的最后一行。作为证明，这里是每个 Range 的行数：

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

将其乘以每个Range 的列数，可以理解为如此庞大的Ranges 分配/取消分配内存以及合并/取消合并单元格需要一些时间。

请试试这个新代码（测试完成后请随时删除MsgBox）：

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

如果您有一个平方数据表（每一列都在同一行结束）表格下方没有写任何内容，更好的方法是将最后一行保存在变量 lLastRow 和每次需要时调用它：

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

编辑：

似乎范围声明只是问题的一部分。其余的滞后是由于工作表的视觉和计算更新。有关上下文，请查看此Guide to efficient VBA code。

要修复它，请尝试在调用 With ThisWorkbook.Worksheets("Data") 之前添加此代码：

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

还有End With之后的这个：

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

您可以使用Timer function 查看执行持续时间，在代码前使用startTimer，在代码后使用endTimer。总时长显示为MsgBox "Duration = " & endTimer - startTimer & "s"。