请求修改VBA代码：从4个源工作簿增量复制数据至合并工作簿

我最近在做一个Excel数据合并的小项目，卡在了增量复制这一步，想请各位帮忙看看代码哪里出问题了，怎么调整才能实现只复制新增数据，避免重复。

先说说项目的具体情况：

• 有4个源工作簿，分别叫GK、SK、RJ、TB
• 每个源工作簿里都有3个同名工作表：products、channels、sales
• 目标合并工作簿（consolidated workbook）也有这3个一模一样的工作表
• 所有工作簿都放在同一个文件夹里
• 需求是：用VBA实现增量复制——只把每个源工作簿各工作表中，上次复制后新增的行，复制到合并工作簿对应的工作表里
• 最开始写的代码会把源表全部数据复制过去，导致合并表重复数据一大堆；后来改了代码还是不对，现在完全不知道怎么调整了
• 所有源和目标工作表的第一列都是DATE列，表结构完全一致

原始代码（会复制全部数据导致重复） #

Sub Copy_From_All_Workbooks()
    Dim wb As String, i As Long, sh As Worksheet
    Application.ScreenUpdating = False
    wb = Dir(ThisWorkbook.Path & "\*")
    Do Until wb = ""
        If wb <> ThisWorkbook.Name Then
            Workbooks.Open ThisWorkbook.Path & "\" & wb
                For Each sh In Workbooks(wb).Worksheets
                        sh.UsedRange.Offset(1).Copy   '<---- Assumes 1 header row
                            ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                        Application.CutCopyMode = False
                Next sh
            Workbooks(wb).Close False
        End If
        wb = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

修改后的代码（仍无法实现增量复制） #

Sub Copy_From_All_Workbooks()
    Dim wb As String, i As Long, sh As Worksheet, fndRng As Range, _
    start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As _
    Range
    Application.ScreenUpdating = False
    wb = Dir(ThisWorkbook.Path & "\*")
    Do Until wb = ""
    If wb <> ThisWorkbook.Name Then
         Workbooks.Open ThisWorkbook.Path & "\" & wb
            For Each sh In Workbooks(wb).Worksheets
            On Error Resume Next
            sh.UsedRange.Offset(1).Copy   '<---- Assumes 1 header row
            Set fndRng = sh.Range("A:A").Find(date_to_find,LookIn:=xlValues, _
        searchdirection:=xlPrevious)
                
                If Not fndRng Is Nothing Then
                    start_of_copy_row = fndRng.Row + 1
                   Else
                   start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
                 End If

                   end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row

                   Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)
                        
                        latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))
                
                       ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        
                   On Error GoTo 0
                   
                   Application.CutCopyMode = False
                   
                Next sh
            Workbooks(wb).Close False
        End If
        wb = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

我自己能看出来修改后的代码想通过DATE列来判断增量，但逻辑肯定有问题，比如date_to_find这个变量根本没定义，而且先复制再找范围的顺序也不对？实在搞不清怎么改了，有没有大佬能帮忙修正一下，实现正确的增量复制？

修正后的增量复制代码 #

Sub IncrementalCopy_From_All_Workbooks()
    Dim wb As String
    Dim sourceWb As Workbook
    Dim sourceSh As Worksheet
    Dim targetSh As Worksheet
    Dim latestDate As Variant
    Dim startCopyRow As Long
    Dim lastSourceRow As Long
    Dim copyRange As Range
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False ' 关闭不必要的弹窗提示
    
    ' 只遍历当前文件夹下的Excel文件，避免匹配到其他类型文件
    wb = Dir(ThisWorkbook.Path & "\*.xlsx")
    Do Until wb = ""
        If wb <> ThisWorkbook.Name Then
            Set sourceWb = Workbooks.Open(ThisWorkbook.Path & "\" & wb)
            
            ' 遍历源工作簿的每个工作表
            For Each sourceSh In sourceWb.Worksheets
                ' 确认目标合并工作簿中存在同名工作表
                On Error Resume Next
                Set targetSh = ThisWorkbook.Sheets(sourceSh.Name)
                On Error GoTo 0
                If targetSh Is Nothing Then GoTo NextSheet ' 目标表不存在则跳过
                
                ' 获取目标工作表DATE列的最新日期
                If targetSh.Cells(targetSh.Rows.Count, 1).End(xlUp).Row > 1 Then
                    ' 目标表已有数据，取DATE列最大值
                    latestDate = Application.WorksheetFunction.Max(targetSh.Range("A:A"))
                Else
                    ' 目标表只有表头，复制所有数据行
                    latestDate = DateSerial(1900, 1, 1) ' 设置一个极小的初始日期
                End If
                
                ' 获取源工作表数据的最后一行
                lastSourceRow = sourceSh.Cells(sourceSh.Rows.Count, 1).End(xlUp).Row
                If lastSourceRow < 2 Then GoTo NextSheet ' 源表只有表头，跳过
                
                ' 查找源表中第一个日期大于最新日期的行（假设DATE列是递增排序的）
                Set copyRange = sourceSh.Range("A2:A" & lastSourceRow).Find(What:=">" & latestDate, _
                    LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
                
                If Not copyRange Is Nothing Then
                    startCopyRow = copyRange.Row
                    ' 定义要复制的完整范围：从起始行到最后一行，包含所有列
                    Set copyRange = sourceSh.Range(sourceSh.Cells(startCopyRow, 1), _
                        sourceSh.Cells(lastSourceRow, sourceSh.UsedRange.Columns.Count))
                    ' 粘贴到目标表的下一行
                    copyRange.Copy
                    targetSh.Cells(targetSh.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                Else
                    ' 没有新增数据，直接跳过
                    GoTo NextSheet
                End If
                
                Application.CutCopyMode = False
NextSheet:
                Set targetSh = Nothing ' 清空对象变量，避免内存泄漏
            Next sourceSh
            
            sourceWb.Close SaveChanges:=False
        End If
        wb = Dir
    Loop
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "增量复制完成！"
End Sub

代码修正说明 #

1. 变量定义与逻辑顺序调整：先获取目标表的最新日期，再确定源表要复制的范围，避免了原代码中先复制再找范围的错误顺序
2. 明确对象引用：所有Range操作都指定了对应的工作表对象，避免默认使用ActiveSheet导致的错误
3. 错误处理增强：增加了目标表不存在、源表无数据的判断，避免运行报错
4. 增量判断逻辑：通过目标表DATE列的最大值，找到源表中大于该日期的起始行，只复制这部分新增数据
5. 效率优化：关闭屏幕更新和弹窗提示，提升代码运行速度

如果你的源表DATE列不是按递增排序的，可以把Find方法改成循环遍历源表的每一行，判断日期是否大于latestDate，再收集需要复制的行。

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