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

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

我必须对 table (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

问题不是来自 Merge,而是来自您声明 rng1rng2rng3 的方式。使用 .End(xlDown) 意味着您的范围将从您的起始行到 sheet 的 最后一行,而不是您的 最后一行数据table。作为证明,这是每个范围的行数:

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

将其乘以每个 Range 的列数,可以理解 allocation/desallocation 内存和 merging/unmerging 单元用于如此大的 Range 需要一些时间.

请尝试这个新代码(测试完成后,请随意删除 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

如果你有一个平方数据 table(每列在同一行结束)并且 table 下方没有任何内容,更好的方法是将最后一行保存在变量 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

编辑:

范围声明似乎只是问题的一部分。其余的滞后是由于工作的视觉和计算更新sheet。对于上下文,请查看此 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"