如何将主工作簿多工作表数据复制到同名独立工作簿？

1. 修正核心逻辑框架 #

现有代码的循环逻辑重复打开文件，不符合需求。我们需要先定位源主工作簿，再遍历指定的目标工作表，匹配对应的CC_xxx目标工作簿完成数据复制。

2. 定义关键变量与常量 #

先把固定的工作表名称、目标工作簿前缀设为常量，方便后续维护：

Sub CopyandPasteDataFromWBs()
    ' 常量定义：固定的目标工作表名称、目标工作簿前缀
    Const TARGET_SHEETS As String = "5532,6789,4325,9999"
    Const WB_PREFIX As String = "CC_"
    
    ' 变量声明
    Dim sourceWb As Workbook ' 源主工作簿
    Dim targetWb As Workbook ' 目标工作簿
    Dim sourceWs As Worksheet ' 源工作表
    Dim targetWs As Worksheet ' 目标工作表
    Dim sheetNames() As String ' 存储需要处理的工作表名称数组
    Dim i As Integer
    Dim targetWbPath As String
    
    ' 设置工作目录
    ChDir "C:\Users\user55\OneDrive - DummyOrg Inc\Documents\Working Files"

3. 打开源主工作簿 #

先让用户选择一次源文件，避免重复操作：

' 选择源主工作簿
    Dim sourceFile As Variant
    sourceFile = Application.GetOpenFilename("Excel文件 (*.xlsx;*.xlsm), *.xlsx;*.xlsm")
    If sourceFile = False Then Exit Sub ' 用户取消则退出
    Set sourceWb = Workbooks.Open(sourceFile)
    
    ' 将工作表名称字符串转为数组
    sheetNames = Split(TARGET_SHEETS, ",")

4. 遍历工作表并完成数据复制 #

循环处理每个目标工作表，匹配对应目标工作簿，复制已使用单元格区域（避免空行空列冗余）：

' 遍历每个需要处理的工作表
    For i = LBound(sheetNames) To UBound(sheetNames)
        On Error Resume Next ' 捕获工作表不存在的情况
        Set sourceWs = sourceWb.Worksheets(sheetNames(i))
        On Error GoTo 0
        
        ' 如果源工作表存在
        If Not sourceWs Is Nothing Then
            ' 构造目标工作簿路径（假设和源文件同目录）
            targetWbPath = ThisWorkbook.Path & "\" & WB_PREFIX & sheetNames(i) & ".xlsx"
            
            ' 检查目标工作簿是否已打开，未打开则尝试打开
            Set targetWb = Nothing
            On Error Resume Next
            Set targetWb = Workbooks(WB_PREFIX & sheetNames(i) & ".xlsx")
            On Error GoTo 0
            
            If targetWb Is Nothing Then
                ' 尝试打开目标工作簿，不存在则提示并跳过
                On Error Resume Next
                Set targetWb = Workbooks.Open(targetWbPath)
                On Error GoTo 0
                If targetWb Is Nothing Then
                    MsgBox "未找到目标工作簿：" & WB_PREFIX & sheetNames(i) & ".xlsx，跳过此工作表。"
                    Set sourceWs = Nothing
                    GoTo NextSheet
                End If
            End If
            
            ' 定位目标工作表（假设名称和源工作表一致）
            On Error Resume Next
            Set targetWs = targetWb.Worksheets(sheetNames(i))
            On Error GoTo 0
            If targetWs Is Nothing Then
                MsgBox "目标工作簿" & WB_PREFIX & sheetNames(i) & "中不存在工作表" & sheetNames(i) & "，跳过此工作表。"
                targetWb.Close SaveChanges:=False
                Set sourceWs = Nothing
                Set targetWb = Nothing
                GoTo NextSheet
            End If
            
            ' 复制源数据到目标工作表（覆盖原有数据，从A1开始）
            sourceWs.UsedRange.Copy
            targetWs.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats ' 按需选择粘贴类型，比如xlPasteAll
            Application.CutCopyMode = False ' 清除复制状态
            
            ' 保存并关闭目标工作簿
            targetWb.Close SaveChanges:=True
            Set targetWs = Nothing
            Set targetWb = Nothing
        Else
            MsgBox "源工作簿中不存在工作表" & sheetNames(i) & "，跳过此工作表。"
        End If
        
NextSheet:
        Set sourceWs = Nothing
    Next i
    
    ' 关闭源主工作簿（按需选择是否保存）
    sourceWb.Close SaveChanges:=False
    MsgBox "所有指定工作表数据复制完成！"
End Sub

5. 关键细节与优化建议 #

• 粘贴类型调整：代码中用xlPasteValuesAndNumberFormats仅复制值和数字格式，若需保留公式、单元格格式，可改为xlPasteAll。
• 错误处理：加入了工作表/工作簿不存在的捕获逻辑，避免代码崩溃。
• 追加数据逻辑：若目标工作簿需要追加数据而非覆盖，可将目标单元格定位改为targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Offset(1, 0)。
• 批量维护：后续新增或修改工作表时，只需修改TARGET_SHEETS常量即可。

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