如何从主Excel自动将数据导出至多工作簿及指定工作表？

原代码报错的常见原因 #

• 用户取消文件选择时，targetFile返回False，直接执行Workbooks.Open会触发错误
• 输入的工作表名称不存在，导致Set wsTarget失败
• 仅支持单个目标文档，无法满足分发到4份文档的需求
• 未处理源数据为空、目标列无数据等边界场景

适配多目标分发的优化代码 #

以下代码支持批量选择多个目标工作簿，自动将主文件的最新数据分发到指定工作表，同时包含错误处理避免崩溃：

Sub BatchDistributeData()
    Dim wbSource As Workbook
    Dim wbTarget As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim lastRowSource As Long
    Dim lastRowTarget As Long
    Dim targetFiles As Variant
    Dim targetSheetName As String
    Dim i As Integer
    
    ' 初始化源工作簿和工作表
    Set wbSource = ThisWorkbook
    On Error Resume Next
    Set wsSource = wbSource.Worksheets("Sheet1")
    On Error GoTo 0
    If wsSource Is Nothing Then
        MsgBox "源工作表Sheet1不存在，请检查！", vbCritical
        Exit Sub
    End If
    
    ' 获取源数据最后一行（工单号所在行）
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    If lastRowSource < 1 Then
        MsgBox "源工作表无数据，请先录入！", vbExclamation
        Exit Sub
    End If
    
    ' 批量选择目标工作簿
    targetFiles = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", Title:="选择所有目标文档", MultiSelect:=True)
    If TypeName(targetFiles) = "Boolean" Then
        MsgBox "未选择任何文件，操作取消", vbInformation
        Exit Sub
    End If
    
    ' 输入目标工作表名称（所有目标文档使用同一工作表名，若不同可修改为循环输入）
    targetSheetName = InputBox("输入目标工作表名称：")
    If targetSheetName = "" Then
        MsgBox "工作表名称不能为空", vbExclamation
        Exit Sub
    End If
    
    ' 遍历每个目标文档分发数据
    Application.ScreenUpdating = False ' 关闭屏幕刷新提升速度
    For i = LBound(targetFiles) To UBound(targetFiles)
        On Error Resume Next
        Set wbTarget = Workbooks.Open(targetFiles(i))
        If Err.Number <> 0 Then
            MsgBox "打开文件失败：" & targetFiles(i), vbCritical
            Err.Clear
            GoTo NextFile
        End If
        
        Set wsTarget = wbTarget.Worksheets(targetSheetName)
        If Err.Number <> 0 Then
            MsgBox "工作表" & targetSheetName & "在文件" & targetFiles(i) & "中不存在", vbCritical
            wbTarget.Close False
            Err.Clear
            GoTo NextFile
        End If
        On Error GoTo 0
        
        ' 获取目标工作表最后一行，粘贴数据
        lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
        wsSource.Range("A" & lastRowSource & ":I" & lastRowSource).Copy wsTarget.Range("A" & lastRowTarget + 1)
        
        ' 保存并关闭目标文档
        wbTarget.Close SaveChanges:=True
        
NextFile:
    Next i
    
    ' 自增下一个工单号
    wsSource.Cells(lastRowSource + 1, "A").Value = wsSource.Cells(lastRowSource, "A").Value + 1
    
    Application.ScreenUpdating = True
    MsgBox "数据分发完成！", vbInformation
End Sub

代码说明 #

• 批量选择：支持一次性选中所有4份目标文档，无需重复操作
• 错误处理：捕获文件打开失败、工作表不存在等异常，避免程序崩溃
• 效率优化：关闭屏幕刷新，减少卡顿
• 边界处理：检查源数据是否为空、用户是否取消操作等场景
• 工单号自增：完成分发后自动生成下一个工单号

使用步骤 #

1. 打开主文件，按Alt+F11打开VBA编辑器
2. 插入新模块，粘贴上述代码
3. 按F5运行宏，按提示选择目标文档、输入工作表名称即可

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