VBA多工作簿多工作表单元格区域批量复制至单工作表问题

问题根源分析 #

• 粘贴覆盖：循环中每次粘贴的目标位置未随迭代动态偏移，始终固定为PasteRangeStart或固定偏移量的位置，导致后续内容覆盖之前的结果
• 单工作表限制：代码仅针对当前活动工作表处理，未遍历多工作表及外部工作簿
• 缺失执行次数统计：未实现L列记录复制执行次数的逻辑

单工作表版本修正代码 #

先解决粘贴覆盖问题，同时添加L列统计功能：

Sub CopyRangeSingleWorksheet_Fixed()
    Dim OffsetAmount As Integer
    OffsetAmount = 7
    Dim FirstRoomMon As Integer, FirstRoomFri As Integer
    FirstRoomMon = 2 '第一个复制区域起始行
    FirstRoomFri = 6 '第一个复制区域结束行
    Dim CopyRowsCount As Integer
    CopyRowsCount = FirstRoomFri - FirstRoomMon + 1 '每次复制的行数（固定5行）
    
    Dim TotalRooms As Integer
    TotalRooms = WorksheetFunction.CountIf(Range("L:L"), "Weekly Total") '统计待复制区域总数
    
    Dim RoomNo As Integer
    Dim PasteTarget As Range
    Set PasteTarget = Worksheets("Test").Range("A210") '初始粘贴位置
    
    For RoomNo = 0 To TotalRooms - 1
        '定义当前要复制的区域
        Dim CurrentCopyRange As Range
        Set CurrentCopyRange = Range(Cells(FirstRoomMon + OffsetAmount * RoomNo, 1), _
                                     Cells(FirstRoomFri + OffsetAmount * RoomNo, 10))
                                     
        '复制到目标位置
        CurrentCopyRange.Copy PasteTarget
        '在L列写入本次执行的序号
        PasteTarget.Offset(0, 11).Value = RoomNo + 1
        '更新下一次粘贴的位置：自动下移本次复制的行数
        Set PasteTarget = PasteTarget.Offset(CopyRowsCount, 0)
    Next RoomNo
End Sub

修正关键点 #

• 新增CopyRowsCount计算每次复制的行数，确保偏移量准确匹配
• 循环从0开始，避免重复复制第一个区域
• 每次粘贴后动态更新PasteTarget，让下一次粘贴位置自动下移
• 同步在对应粘贴区域的首行L列写入执行次数序号

扩展为多工作表+多工作簿版本 #

实现从多个外部工作簿的多工作表中批量复制数据：

Sub CopyRangeMultipleWorkbooksWorksheets()
    Dim OffsetAmount As Integer
    OffsetAmount = 7
    Dim FirstRoomMon As Integer, FirstRoomFri As Integer
    FirstRoomMon = 2
    FirstRoomFri = 6
    Dim CopyRowsCount As Integer
    CopyRowsCount = FirstRoomFri - FirstRoomMon + 1
    
    '指定目标工作表（当前工作簿的Test表）
    Dim PasteWs As Worksheet
    Set PasteWs = ThisWorkbook.Worksheets("Test")
    Dim PasteTarget As Range
    Set PasteTarget = PasteWs.Range("A210")
    
    '让用户批量选择源工作簿
    Dim FileDialogObj As FileDialog
    Set FileDialogObj = Application.FileDialog(msoFileDialogFilePicker)
    With FileDialogObj
        .AllowMultiSelect = True
        .Filters.Add "Excel文件", "*.xlsx;*.xlsm"
        If .Show <> -1 Then Exit Sub '用户取消选择则退出
    End With
    
    Dim ExecCount As Integer
    ExecCount = 0 '全局执行次数计数器
    
    '遍历选中的每个源工作簿
    Dim FilePath As Variant
    For Each FilePath In FileDialogObj.SelectedItems
        Dim SourceWb As Workbook
        Set SourceWb = Workbooks.Open(FilePath, ReadOnly:=True)
        
        '遍历源工作簿中的每个工作表
        Dim SourceWs As Worksheet
        For Each SourceWs In SourceWb.Worksheets
            Dim TotalRooms As Integer
            On Error Resume Next '避免工作表无"Weekly Total"时出错
            TotalRooms = WorksheetFunction.CountIf(SourceWs.Range("L:L"), "Weekly Total")
            On Error GoTo 0
            
            If TotalRooms > 0 Then
                Dim RoomNo As Integer
                For RoomNo = 0 To TotalRooms - 1
                    ExecCount = ExecCount + 1 '计数器递增
                    
                    '定义当前要复制的区域（指定工作表，避免跨表错误）
                    Dim CurrentCopyRange As Range
                    Set CurrentCopyRange = SourceWs.Range(SourceWs.Cells(FirstRoomMon + OffsetAmount * RoomNo, 1), _
                                                         SourceWs.Cells(FirstRoomFri + OffsetAmount * RoomNo, 10))
                                                         
                    CurrentCopyRange.Copy PasteTarget
                    '在L列写入全局执行次数
                    PasteTarget.Offset(0, 11).Value = ExecCount
                    
                    '更新粘贴位置
                    Set PasteTarget = PasteTarget.Offset(CopyRowsCount, 0)
                Next RoomNo
            End If
        Next SourceWs
        
        SourceWb.Close SaveChanges:=False '关闭源工作簿，不保存
    Next FilePath
End Sub

扩展功能说明 #

• 支持批量选择多个源工作簿
• 自动遍历每个源工作簿的所有工作表
• 加入错误处理，避免工作表无"Weekly Total"标记时崩溃
• 全局计数器统计所有复制操作的总次数，写入对应粘贴区域的L列
• 源工作簿以只读模式打开，避免文件锁定冲突

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