VBA按日期条件匹配插入区间数据的脚本修改咨询

核心调整逻辑 #

• 提取数据源文件的最小日期：打开CSV文件后读取数据区域首行（即第二行，首行是表头）的A列日期，作为覆盖的起始匹配值
• 定位主表粘贴起点：在主表A列搜索上述起始日期，匹配到的行号作为粘贴起始位置
• 兼容边界场景：如果主表未匹配到对应起始日期，自动将数据追加到现有数据末尾
• 优化原有代码冗余操作：移除不必要的Activate、Select调用，降低运行异常概率

调整后完整代码 #

Sub Code()
    Dim wb1 As Workbook
    Dim raspuns As String
    Dim FSO As Object, fld
    Dim dtLastRun As Date
    Dim dtSourceStart As Date ' 数据源起始日期
    Dim pasteStartRow As Long ' 主表粘贴起始行
    Dim sourceRng As Range ' 数据源待复制范围
    Dim mainSht As Worksheet, sourceSht As Worksheet
    Dim findRng As Range
    
    Const FOLDER_PATH = "\\emag.local\ro\Financial\Controlling&Reporting\Reporting\6_Marketing\FY_2021\Budget\RO\Drivers\Input Daily Reports"
    
    Application.ScreenUpdating = False
    Set mainSht = ThisWorkbook.Worksheets("PPV")
    
    ' 获取上次运行日期
    dtLastRun = mainSht.Range("A" & Rows.Count).End(xlUp).Value
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    For Each fld In FSO.getfolder(FOLDER_PATH).SubFolders
        If (fld.Name > Format(dtLastRun, "yyyy_mm_dd")) And _
           (fld.Name <= Format(Now, "yyyy_mm_dd")) Then
            
            Set wb1 = Workbooks.Open("\\" & fld & "\PPV.csv")
            Set sourceSht = wb1.Worksheets("PPV")
            
            ' 定位数据源待复制范围
            Set sourceRng = sourceSht.Range("A2", sourceSht.Range("A2").End(xlDown).End(xlToRight))
            ' 提取数据源起始日期（数据区域第一行的A列值）
            dtSourceStart = sourceSht.Range("A2").Value
            
            ' 在主表A列查找起始日期对应的行
            Set findRng = mainSht.Range("A:A").Find(What:=dtSourceStart, LookIn:=xlValues, LookAt:=xlWhole)
            If Not findRng Is Nothing Then
                ' 找到对应日期，从该行开始粘贴
                pasteStartRow = findRng.Row
            Else
                ' 未找到对应日期，追加到现有数据末尾
                pasteStartRow = mainSht.Range("A" & Rows.Count).End(xlUp).Row + 1
            End If
            
            ' 复制粘贴数据，无需选中
            sourceRng.Copy mainSht.Range("A" & pasteStartRow)
            
            Application.CutCopyMode = False
            wb1.Close SaveChanges:=False
            
            Set wb1 = Nothing
            Set sourceRng = Nothing
            Set findRng = Nothing
        End If
    Next fld
    
    Application.ScreenUpdating = True
End Sub

使用注意事项 #

• 需确保主表和数据源的日期均存储在A列，且日期格式完全一致，避免匹配失败
• 如果日期存储列有调整，修改代码中对应列的索引即可
• 若数据源的表头结构有变化，可同步调整数据源范围的定位逻辑

内容的提问来源于stack exchange，提问作者Dan Andrei Sica