求助：Excel Subtotal宏运行极慢，求代码优化方案

现有约4000行数据，使用VBA宏执行Subtotal操作需耗时约1小时，而手动执行仅需40秒。以下是针对提供代码的优化方案，核心优化点及完整代码如下：

核心优化点 #

• 关闭Excel交互特性：宏运行期间关闭屏幕更新、自动计算、事件触发，避免不必要的界面刷新和资源消耗，这是提升VBA运行速度的基础操作。
• 移除Select/Activate操作：原代码大量依赖Select和Activate触发界面交互，直接通过工作表、单元格对象操作可彻底避免这类低效行为。
• 缩小操作范围：将清除内容/格式的范围从固定999999行改为仅覆盖实际使用的行，减少无效操作。
• 优化数据传输：用值传递替代带格式的复制粘贴，仅保留必要数据，降低内存占用和操作耗时。
• 批量处理公式：直接向整列批量写入VLOOKUP公式，替代AutoFill，提升公式填充效率。
• 简化排序逻辑：直接通过目标工作表对象调用排序功能，避免依赖ActiveWorkbook，逻辑更清晰且高效。

完整优化代码 #

Sub XX()
    ' 关闭Excel交互特性，提升运行速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    ' 定义工作簿和工作表对象
    Dim wd As Workbook, wx As Worksheet, wy As Worksheet
    Set wd = ThisWorkbook
    Set wx = wd.Worksheets("XX")
    Set wy = wd.Worksheets("Data")
    
    ' 清除目标表内容和格式（仅处理实际使用范围）
    Dim wx_lastRow As Long, wy_lastRow As Long
    wx_lastRow = wx.Cells(wx.Rows.Count, 1).End(xlUp).Row
    If wx_lastRow >= 1 Then
        wx.Range("A1:Z" & wx_lastRow).ClearContents
        wx.Range("A1:Z" & wx_lastRow).ClearFormats
        wx.Columns("L:L").RemoveSubtotal
    End If
    
    wy_lastRow = wy.Cells(wy.Rows.Count, 1).End(xlUp).Row
    If wy_lastRow >= 1 Then
        wy.Range("A1:Z" & wy_lastRow).ClearContents
        wy.Range("A1:Z" & wy_lastRow).ClearFormats
    End If
    
    ' 选择并导入BB文件
    MsgBox "Please Open BB File"
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb; *.csv"
        
        If .Show = True Then
            Dim i As Integer, ts As Workbook, ws As Worksheet, ws_row As Long
            For i = 1 To .SelectedItems.Count
                Set ts = Workbooks.Open(.SelectedItems(i))
                Set ws = ts.Worksheets(1)
                ws_row = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
                
                ' 直接赋值数据，替代复制粘贴
                wx.Range("A1:S" & ws_row).Value = ws.Range("A1:S" & ws_row).Value
                
                ts.Close savechanges:=False
            Next i
        End If
    End With
    
    ' 选择并导入Summary Display文件
    MsgBox "Please Open Summary Display File"
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb; *.csv"
        
        If .Show = True Then
            Dim tp As Workbook, wp As Worksheet, wp_row As Long, wp_new_row As Long
            For i = 1 To .SelectedItems.Count
                Set tp = Workbooks.Open(.SelectedItems(i))
                Set wp = tp.Worksheets(1)
                wp_row = wp.Cells(wp.Rows.Count, 1).End(xlUp).Row
                
                ' 筛选数据
                wp.Range("A1:O1").AutoFilter
                wp.Range("A1:O" & wp_row).AutoFilter Field:=1, Criteria1:= _
                    "=Check BB Grouping", Operator:=xlOr, Criteria2:="=Check Manually"
                wp.Range("A1:O" & wp_row).AutoFilter Field:=3, Criteria1:="<>"
                
                wp_new_row = wp.Cells(wp.Rows.Count, 1).End(xlUp).Row
                ' 直接赋值筛选后的数据
                wy.Range("A1:C" & wp_new_row).Value = wp.Range("A1:C" & wp_new_row).Value
                
                tp.Close savechanges:=False
            Next i
        End If
    End With
    
    ' 整理Summary Display表列结构
    wy.Columns("A:A").Cut
    wy.Columns("D:D").Insert Shift:=xlToRight
    wy.Columns("A:A").TextToColumns Destination:=wy.Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    
    ' 对XX表进行排序
    wx_lastRow = wx.Cells(wx.Rows.Count, 1).End(xlUp).Row
    With wx.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wx.Range("F2:F" & wx_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending
        .SortFields.Add Key:=wx.Range("E2:E" & wx_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending
        .SortFields.Add Key:=wx.Range("E2:E" & wx_lastRow), SortOn:=xlSortOnCellColor, Order:=xlAscending
        .SortFields.Add(wx.Range("E2:E" & wx_lastRow), xlSortOnCellColor, xlAscending).SortOnValue.Color = RGB(204, 255, 204)
        .SetRange wx.Range("A1:S" & wx_lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' 调整XX表列顺序
    wx.Columns("G:G").Cut
    wx.Columns("B:B").Insert Shift:=xlToRight
    
    wx.Columns("I:I").Cut
    wx.Columns("C:C").Insert Shift:=xlToRight
    
    wx.Columns("O:O").Cut
    wx.Columns("G:G").Insert Shift:=xlToRight
    
    ' 处理价格列格式
    wx.Columns("G:G").TextToColumns Destination:=wx.Range("G1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    wx.Columns("G:G").NumberFormat = "0.00"
    wx.Columns("G:G").Interior.Color = 65535
    
    ' 新增列并设置表头
    wx.Columns("A:A").Insert Shift:=xlToRight
    wx.Range("A1").Value = "Check BB No."
    
    ' 批量写入VLOOKUP公式并转为值
    wx.Range("A2:A" & wx_lastRow).FormulaR1C1 = "=VLOOKUP(RC[2],'Summary Display'!C[1]:C[2],2,FALSE)"
    wx.Range("A2:A" & wx_lastRow).Value = wx.Range("A2:A" & wx_lastRow).Value
    
    ' 新增操作列
    wx.Columns("F:F").Insert Shift:=xlToRight
    wx.Range("F1").Value = "Action"
    
    wx.Columns("G:G").Insert Shift:=xlToRight
    wx.Range("G1").Value = "New Promo No."
    
    wx.Columns("H:H").Insert Shift:=xlToRight
    wx.Range("H1").Value = "New BB No."
    
    ' 设置筛选和自动列宽
    wx.Range("A1").AutoFilter
    wx.Columns("A:L").EntireColumn.AutoFit
    
    ' 执行Subtotal并删除目标列
    Dim Rng As Range
    Set Rng = wx.Range("L1:L" & wx_lastRow)
    Rng.Subtotal GroupBy:=1, Function:=xlCount, TotalList:=Array(1), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    wx.Columns("L:L").Delete
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

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