VBA处理较大Excel数据集时卡顿冻结的效率优化咨询

我制作了一款支持用户输入数据的Excel工作簿，程序会从独立工作表提取公式，粘贴至数据集工作表，再按照业务流程要求的特定规则完成全量数据排序。
为提升运行效率，我已采取多项基础优化措施：关闭自动计算，仅在必要时触发计算，计算完成后将公式区域粘贴为值；同时关闭屏幕更新、状态栏显示、事件触发机制，这些均为易落地的初级优化手段。
当前代码处理2.5万行及以下规模的较小数据集时运行顺畅，但处理更大体量数据集时性能会严重下降，尤其在处理4.8万行数据时，经常出现Excel冻结无响应的问题。
原实现代码如下：

Worksheets("Update Indicator").Visible = True
Sheets("Update Indicator").Range("B1") = 1
Dim LossSort As Workbook
Dim WC As Worksheet
Dim WC_Form As Worksheet
Dim lastRow As Long
Dim StartTime As Double
Dim SecondsElapsed As Double

StartTime = Timer

Set LossSort = ThisWorkbook
Set WC = LossSort.Sheets("WC Losses")
Set WC_Form = LossSort.Sheets("WC Formulas")

If WC.AutoFilterMode Then
    WC.AutoFilterMode = False
End If

lastRow = WC.Range("V" & Rows.Count).End(xlUp).Row

    'Code to help speed up macro
With Application
 .Calculation = xlCalculationManual
 .ScreenUpdating = False
 .DisplayStatusBar = False
 .EnableEvents = False
End With

    Calculate
          
    'Test if the value in cell U2 is blank/empty
    If IsEmpty(WC.Range("W2").Value) = True Then
      MsgBox "No WC Losses Available"
      Exit Sub
    Else
    End If

    'Set Original Order
    WC.Range("BH2") = 1
    WC.Range("BH2:BH" & lastRow).DataSeries , xlDataSeriesLinear
    
    'Copy formulas from WC Formulas tab to WC Losses
    WC_Form.Range("A2:U2").Copy Destination:=WC.Range("A2:U" & lastRow)
    WC_Form.Range("AX2:BG2").Copy Destination:=WC.Range("AX2:BG" & lastRow)
   
    'Calculate
    WC.Calculate
    
    'Apply formatting across the dataset
    WC_Form.Range("L2:AM2").Copy
    WC.Range("L2:O" & lastRow).PasteSpecial Paste:=xlPasteFormats
    
    'Sort by Acc Desc and Claim# then by Closed No Pay, Loss Date, State
    
        With Sheets("WC Losses").Cells(1, 1).CurrentRegion.Cells
            .Sort Key1:=Range("Z1"), Order1:=xlAscending, _
                Key2:=Range("V1"), Order2:=xlAscending, _
                Orientation:=xlTopToBottom, Header:=xlYes
        End With
    
            With Sheets("WC Losses").Cells(1, 1).CurrentRegion.Cells
            .Sort Key1:=Range("K1"), Order1:=xlAscending, _
                Key2:=Range("W1"), Order2:=xlAscending, _
                Key3:=Range("X1"), Order3:=xlAscending, _
                Orientation:=xlTopToBottom, Header:=xlYes
        End With
      
    'Paste values over formulas
    WC.Calculate
    
    Dim rng1 As Range
    Set rng1 = WC.Range("A2:T" & lastRow)
    WC.Range("A2").Resize(rng1.Rows.Count, rng1.Columns.Count).Cells.Value = rng1.Cells.Value
    
    Dim rng2 As Range
    Set rng2 = WC.Range("AX2:BG" & lastRow)
    WC.Range("AX2").Resize(rng2.Rows.Count, rng2.Columns.Count).Cells.Value = rng2.Cells.Value
       
    Sheets("Update Indicator").Range("C5").Copy Destination:=Sheets("Update Indicator").Range("B5")
    Sheets("Update Indicator").Calculate
    Sheets("Update Indicator").Range("B5").Copy
    Sheets("Update Indicator").Range("B5").PasteSpecial Paste:=xlPasteValues
    Worksheets("Update Indicator").Visible = False

finish:

ActiveWorkbook.RefreshAll

With Application
 .Calculation = xlCalculationAutomatic
 .ScreenUpdating = True
 .DisplayStatusBar = True
 .EnableEvents = True
End With

    SecondsElapsed = Round(Timer - StartTime, 2)
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

• 应用优化配置时机错误，前置操作产生大量无效开销
  现有代码先做工作表显示切换、单元格赋值、行号获取，之后才关闭自动计算、屏幕更新、事件触发，前面的所有操作都会触发界面重绘、实时计算，平白浪费性能。而且配置完成后直接调用全局Calculate强制全工作簿计算，后续本就只需要计算WC工作表，这步全局计算在大文件场景下会占用数秒甚至数十秒的无用时间。
• 空值判断逻辑位置靠后，存在无用执行路径
  现有代码做完全局计算、优化配置之后才判断W2是否为空，无数据场景下前面的操作全部白费，而且直接Exit Sub不会恢复应用的计算、屏幕更新配置，会导致用户后续使用Excel出现功能异常。
• 跨表复制全走剪贴板，效率极低
  现有代码中公式复制、格式复制、单元格值复制全部用Copy/PasteSpecial走系统剪贴板，剪贴板操作本身开销大，还可能触发其他剪贴板监听程序的额外占用。批量写入公式、格式、值完全不需要走剪贴板，直接通过Range对象的Formula、NumberFormat、Value属性批量赋值，速度比剪贴板操作快5-10倍。
• 同区域重复排序，性能开销翻倍
  现有代码对同一份数据连续做两次独立排序，每次排序Excel都需要全量遍历所有行完成比较、重排，两次操作直接让排序环节耗时翻倍。所有排序规则可以合并到单次Sort调用中，仅做一次全量排序即可，排序结果和两次排序完全一致。另外排序时用CurrentRegion模糊匹配区域，会额外触发Excel的区域边界检测逻辑，直接指定精确的数据范围速度更快，也能避免范围识别错误。
• 冗余的Range对象调用，产生不必要的COM交互开销
  代码开头已经用Set赋值了WC、WC_Form等工作表对象，但后续操作中反复写Sheets("WC Losses")、Sheets("Update Indicator")重新取对象，每次取对象都需要和Excel进程做COM交互，积少成多也会拖慢速度。另外转值操作中多余的Resize调用完全没有必要，直接对目标范围赋值即可。
• 无意义的全量刷新操作
  代码末尾的ActiveWorkbook.RefreshAll会触发工作簿内所有外部数据连接、透视表的全量刷新，在已经把所有公式转为静态值的场景下，这步操作没有实际作用，反而会触发大量额外计算和IO开销。
• 缺少错误兜底机制
  现有代码没有错误捕获，一旦运行中报错（比如大文件下的内存不足、范围识别错误），会直接跳过应用配置恢复步骤，导致Excel一直处于手动计算、屏幕不更新的异常状态。

Dim LossSort As Workbook
Dim WC As Worksheet
Dim WC_Form As Worksheet
Dim uiWs As Worksheet
Dim lastRow As Long
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim sortRng As Range

StartTime = Timer
Set LossSort = ThisWorkbook
Set WC = LossSort.Worksheets("WC Losses")
Set WC_Form = LossSort.Worksheets("WC Formulas")
Set uiWs = LossSort.Worksheets("Update Indicator")

' 绑定错误兜底，确保异常时也能恢复应用配置
On Error GoTo finish

' 提前关闭筛选
If WC.AutoFilterMode Then WC.AutoFilterMode = False
' 提前判断数据是否存在，无数据直接退出
lastRow = WC.Range("V" & Rows.Count).End(xlUp).Row
If IsEmpty(WC.Range("W2").Value) Then
    MsgBox "No WC Losses Available"
    GoTo finish
End If

' 统一应用性能优化配置
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .EnableEvents = False
End With

' UI操作放到优化配置之后，避免闪屏
uiWs.Visible = True
uiWs.Range("B1") = 1

' 填充原始序号
WC.Range("BH2").Value = 1
WC.Range("BH2:BH" & lastRow).DataSeries , xlDataSeriesLinear

' 批量写入公式，不走剪贴板
WC.Range("A2:U" & lastRow).Formula = WC_Form.Range("A2:U2").Formula
WC.Range("AX2:BG" & lastRow).Formula = WC_Form.Range("AX2:BG2").Formula

' 仅计算目标工作表
WC.Calculate

' 批量写入格式，不走剪贴板，仅复制实际需要的L:O列格式
WC.Range("L2:O" & lastRow).NumberFormat = WC_Form.Range("L2:O2").NumberFormat
' 若需要复制字体、填充等其他格式，可参照上面的写法直接赋值对应格式属性

' 合并两次排序为一次，优先级与原逻辑完全一致：K > W > X > Z > V
Set sortRng = WC.Range("A1:BH" & lastRow)
sortRng.Sort Key1:=WC.Range("K1"), Order1:=xlAscending, _
    Key2:=WC.Range("W1"), Order2:=xlAscending, _
    Key3:=WC.Range("X1"), Order3:=xlAscending, _
    Key4:=WC.Range("Z1"), Order4:=xlAscending, _
    Key5:=WC.Range("V1"), Order5:=xlAscending, _
    Orientation:=xlTopToBottom, Header:=xlYes

' 公式转值，直接赋值不走剪贴板
WC.Calculate
WC.Range("A2:T" & lastRow).Value = WC.Range("A2:T" & lastRow).Value
WC.Range("AX2:BG" & lastRow).Value = WC.Range("AX2:BG" & lastRow).Value

' 处理UI表数值，直接赋值不走剪贴板
uiWs.Range("B5").Value = uiWs.Range("C5").Value
uiWs.Visible = False

finish:
' 无论是否报错都恢复应用配置
With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .EnableEvents = True
End With

' 确有外部连接刷新需求再打开下面的代码，默认注释减少开销
' ActiveWorkbook.RefreshAll

SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

按上述逻辑优化后，4.8万行数据的处理耗时通常能降到原代码的20%以内，基本不会出现Excel冻结无响应的问题。

内容的提问来源于stack exchange，提问作者wolffer