Excel VBA实现多文件数据提取并复制至新工作表问题求助

需求概述 #

• 主控工作簿通过「MAIN SHEET」管理待处理文件：A列存文件路径/名称，B列存对应工作表名称
• 实现按钮触发的批量处理：遍历A列可变数量的文件（1-40个）
• 处理逻辑：
  1. 打开目标文件并提取全部数据
  2. 对应工作表不存在则新建并命名，存在则清空原有数据
  3. 将新数据写入目标工作表

完整VBA代码 #

' 获取指定工作表指定列的最后一行行号
Function getLastRow(ws As Worksheet, col As String) As Long
    getLastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
End Function

Sub RunThroughList()
    Dim numFiles As Long
    Dim currFile As String
    Dim targetSheetName As String
    Dim targetWs As Worksheet
    Dim sourceWb As Workbook
    Dim sourceWs As Worksheet
    Dim devMode As Boolean ' 改为Boolean类型更贴合逻辑
    devMode = False
    
    ' 关闭屏幕更新和警报，提升运行速度并避免弹窗干扰
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    With ThisWorkbook ' 用ThisWorkbook替代ActiveWorkbook，避免激活其他文件时出错
        numFiles = getLastRow(.Sheets("MAIN SHEET"), "A")
        If devMode Then MsgBox "待处理文件数量：" & numFiles
        
        ' 遍历文件列表（跳过表头行）
        For i = 2 To numFiles
            currFile = .Sheets("MAIN SHEET").Cells(i, 1).Value
            targetSheetName = .Sheets("MAIN SHEET").Cells(i, 2).Value
            
            ' 跳过空文件路径
            If currFile = "" Then GoTo NextFile
            
            ' 检查目标工作表是否存在
            On Error Resume Next
            Set targetWs = .Sheets(targetSheetName)
            On Error GoTo 0
            
            ' 工作表不存在则新建，存在则清空数据
            If targetWs Is Nothing Then
                Set targetWs = .Sheets.Add(After:=.Sheets(.Sheets.Count))
                targetWs.Name = targetSheetName
            Else
                ' 清空原有数据（保留格式）
                targetWs.Cells.ClearContents
            End If
            
            ' 打开源文件并复制数据
            On Error Resume Next
            Set sourceWb = Workbooks.Open(currFile)
            If Err.Number <> 0 Then
                If devMode Then MsgBox "文件无法打开：" & currFile
                GoTo NextFile
            End If
            On Error GoTo 0
            
            ' 默认取源文件第一个工作表的数据，可根据需求修改
            Set sourceWs = sourceWb.Sheets(1)
            ' 复制源表所有已使用数据到目标表的A1开始位置
            sourceWs.UsedRange.Copy targetWs.Range("A1")
            
            ' 关闭源文件，不保存更改
            sourceWb.Close SaveChanges:=False
            
NextFile:
            ' 重置对象变量
            Set targetWs = Nothing
            Set sourceWb = Nothing
            Set sourceWs = Nothing
        Next i
    End With
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    If devMode Then MsgBox "数据同步完成！"
End Sub

代码关键解析 #

• 工作表存在性检查：通过On Error Resume Next捕获工作表不存在的错误，避免重复创建或运行报错
• 静默运行优化：关闭ScreenUpdating和DisplayAlerts，减少屏幕闪烁和不必要的确认弹窗
• 异常处理：针对文件无法打开的情况做容错处理，确保程序不会中断
• 数据处理逻辑：
  • 新建工作表：在工作簿末尾添加新表并命名
  • 已有工作表：仅清空内容保留格式，避免重置表样式
  • 数据复制：复制源文件第一个工作表的所有已使用区域，可根据需求修改为指定工作表
• 对象管理：每次循环后重置对象变量，避免内存泄漏

内容的提问来源于stack exchange，提问作者BiG-tasTy