高效实现多工作表可变行数据汇总至单个工作表的方法

需求回顾 #

• 需将17个命名为Site#的工作表数据复制到Data汇总表
• 所有工作表忽略第1-3行
• 仅从Site1复制第4行作为列标题
• 其余站点从第5行开始复制数据
• 仅复制A:AT列范围
• 手动触发刷新，先清空Data表再执行复制
• 仅粘贴值，去除公式、条件格式等，总数据约900行

原代码问题分析 #

原代码存在重复冗余（逐个编写Site1、Site2的逻辑）、逐行复制效率低、未处理仅粘贴值的需求等问题，以下是优化后的实现：

优化后的VBA代码 #

Sub RefreshData()
    Dim wsData As Worksheet
    Dim wsSite As Worksheet
    Dim lastRow As Long
    Dim pasteRow As Long
    Dim i As Integer
    
    ' 禁用不必要操作提升运行速度
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    ' 初始化Data工作表
    Set wsData = ThisWorkbook.Worksheets("DATA")
    wsData.Cells.Clear
    wsData.Cells.EntireRow.Hidden = False
    wsData.Cells.EntireColumn.Hidden = False
    pasteRow = 1 ' 从第一行开始粘贴
    
    ' 处理Site1：复制标题行和数据行
    Set wsSite = ThisWorkbook.Worksheets("SITE1")
    lastRow = wsSite.Cells(wsSite.Rows.Count, "A").End(xlUp).Row
    ' 复制标题行（A:AT列）并仅粘贴值
    wsSite.Range("A4:AT4").Copy
    wsData.Range("A" & pasteRow).PasteSpecial xlPasteValues
    pasteRow = pasteRow + 1
    ' 复制第5行及以后的数据
    If lastRow >= 5 Then
        wsSite.Range("A5:AT" & lastRow).Copy
        wsData.Range("A" & pasteRow).PasteSpecial xlPasteValues
        pasteRow = pasteRow + (lastRow - 4)
    End If
    
    ' 批量处理Site2到Site17
    For i = 2 To 17
        On Error Resume Next ' 跳过不存在的工作表
        Set wsSite = ThisWorkbook.Worksheets("SITE" & i)
        On Error GoTo 0
        
        If Not wsSite Is Nothing Then
            lastRow = wsSite.Cells(wsSite.Rows.Count, "A").End(xlUp).Row
            ' 从第5行开始复制数据
            If lastRow >= 5 Then
                wsSite.Range("A5:AT" & lastRow).Copy
                wsData.Range("A" & pasteRow).PasteSpecial xlPasteValues
                pasteRow = pasteRow + (lastRow - 4)
            End If
            Set wsSite = Nothing ' 释放对象
        End If
    Next i
    
    ' 执行后续绑定操作
    Call setCategories
    Call setAge
    ActiveWorkbook.RefreshAll
    
    ' 恢复应用默认设置
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .CutCopyMode = False ' 清除复制模式
    End With
    
    MsgBox "All Data Refreshed.", vbOKOnly
End Sub

优化点说明 #

• 批量复制替代逐行循环：直接复制整段数据区域，避免逐行复制的低效操作，大幅提升运行速度
• 循环批量处理工作表：用For循环统一处理Site2到Site17，消除冗余代码，降低维护成本
• 严格仅粘贴值：通过PasteSpecial xlPasteValues实现需求，彻底去除原数据的公式、格式等
• 禁用后台资源消耗：关闭屏幕更新、事件触发、自动计算，减少运行时的系统资源占用
• 添加错误处理：跳过不存在的工作表，提升代码的健壮性
• 优化对象引用：明确声明工作表对象，避免重复调用Sheets()，提升代码可读性与执行效率

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