VBA按日期跨工作簿复制数据不全、日期筛选失效问题求助

问题原因 #

• 数据复制不全：当前使用的Range("A2").End(xlDown).End(xlToRight)选择逻辑和手动按Ctrl+方向键效果一致，碰到定位路径上第一个空白单元格就会终止，只要数据区域A列存在空行、或者起始行存在空列，空白后方的所有内容都会被漏选。
• 日期范围选择失效：现有代码仅支持单日期输入，没有实现范围判断逻辑；同时InputBox默认返回字符串类型，未做日期格式校验时，直接传入Format函数极易因系统日期格式差异生成错误的文件路径，导致文件打开失败。

注意：运行代码前请将sourcePath变量的取值替换为你实际存放源报表的文件夹路径，如果需要指定固定的源/目标工作表，可修改代码中对应Sheets()的参数。

修正后完整代码 #

Sub P_file()
    Dim startDate As Date, endDate As Date
    Dim sourcePath As String
    Dim wbSource As Workbook, wbTarget As Workbook
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim pasteRow As Long
    Dim fileName As String
    Dim fileDate As Date
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 初始化目标工作簿（当前运行代码的工作簿）
    Set wbTarget = ThisWorkbook
    Set wsTarget = wbTarget.ActiveSheet
    pasteRow = 2 ' 数据粘贴起始行
    
    ' 获取并校验日期范围输入
    On Error Resume Next
    startDate = CDate(InputBox("请输入待处理报表的起始日期（格式示例：2024/1/1）"))
    endDate = CDate(InputBox("请输入待处理报表的结束日期（格式示例：2024/1/31）"))
    On Error GoTo 0
    If startDate = 0 Or endDate = 0 Or startDate > endDate Then
        MsgBox "日期输入不合法，请重新运行程序"
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    ' 配置源报表存放文件夹路径
    sourcePath = "C:\cpark\"
    If Right(sourcePath, 1) <> "\" Then sourcePath = sourcePath & "\"
    
    ' 遍历文件夹下所有符合命名规则的xlsx文件
    fileName = Dir(sourcePath & "monthfile_*.xlsx")
    Do While fileName <> ""
        ' 从文件名提取日期，适配m_d_yyyy的命名格式
        On Error Resume Next
        fileDate = CDate(Replace(Split(Split(fileName, ".")(0), "_")(1) & "/" & _
                                Split(Split(fileName, ".")(0), "_")(2) & "/" & _
                                Split(Split(fileName, ".")(0), "_")(3), "_", "/"))
        On Error GoTo 0
        
        ' 仅处理日期在选定范围内的文件
        If fileDate >= startDate And fileDate <= endDate Then
            ' 只读方式打开符合条件的源文件
            Set wbSource = Workbooks.Open(Filename:=sourcePath & fileName, ReadOnly:=True)
            Set wsSource = wbSource.Sheets(1)
            
            ' 反向查找定位源表最后一个非空单元格，彻底避免空单元格导致的范围漏选
            lastRow = wsSource.Cells.Find(What:="*", After:=wsSource.Range("A1"), _
                                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            lastCol = wsSource.Cells.Find(What:="*", After:=wsSource.Range("A1"), _
                                        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
            
            ' 直接通过值赋值完成数据传递，不调用剪贴板，速度更快稳定性更高
            wsTarget.Range(wsTarget.Cells(pasteRow, 1), wsTarget.Cells(pasteRow + lastRow - 2, lastCol)).Value = _
                wsSource.Range(wsSource.Cells(2, 1), wsSource.Cells(lastRow, lastCol)).Value
            
            ' 更新下一批数据的粘贴起始行，避免多文件数据互相覆盖
            pasteRow = pasteRow + lastRow - 1
            
            ' 关闭源文件，不保存任何改动
            wbSource.Close SaveChanges:=False
        End If
        ' 匹配下一个文件
        fileName = Dir
    Loop
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "指定日期范围内的报表数据已全部复制完成"
End Sub

关键修改点 #

• 替换数据范围定位逻辑：从原来的正向End方向键查找，改为从工作表右下角反向查找最后一个非空单元格，无论数据区域中间存在多少空白行、空白列，都能完整覆盖所有有效数据
• 实现完整日期范围筛选：支持输入起止日期，自动校验输入合法性，自动从文件名提取日期判断是否符合筛选规则，无需手动输入完整文件名
• 所有单元格、工作簿、工作表对象都显式指定归属，不会因为活动窗口切换导致引用错位
• 改用单元格值直接赋值的方式替代剪贴板复制粘贴，运行速度提升明显，也不会出现剪贴板锁定、粘贴格式错乱的问题
• 新增批量遍历逻辑，自动处理日期范围内所有符合命名规则的报表文件，不需要逐个手动打开操作

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