Excel VBA按指定日期范围跨工作簿导入数据的代码调整求助

Sub Get_Data_From_File()
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    Dim startDate As Date, endDate As Date
    Dim srcSheet As Worksheet
    Dim visibleRng As Range
    
    ' 读取用户输入的起止日期并校验合法性
    If Not IsDate(ThisWorkbook.Worksheets("Instructions").Range("C8").Value) Or _
       Not IsDate(ThisWorkbook.Worksheets("Instructions").Range("E8").Value) Then
        MsgBox "请在Instructions工作表C8、E8单元格输入合法的起止日期"
        Exit Sub
    End If
    startDate = ThisWorkbook.Worksheets("Instructions").Range("C8").Value
    endDate = ThisWorkbook.Worksheets("Instructions").Range("E8").Value
    
    Application.ScreenUpdating = False
    FileToOpen = Application.GetOpenFilename(Title:="浏览并选择需要导入的ADR文件", FileFilter:="Excel Files (*.xls*),*xls*")
    
    If FileToOpen <> False Then
        Set OpenBook = Application.Workbooks.Open(FileToOpen)
        Set srcSheet = OpenBook.Worksheets("Report Data")
        
        ' 清除原有筛选，添加日期范围筛选
        If srcSheet.AutoFilterMode Then srcSheet.AutoFilterMode = False
        With srcSheet.Range("A8:MJ128") ' 范围包含第8行表头才能正常筛选
            .AutoFilter Field:=9, Criteria1:=">=" & CDbl(startDate), Operator:=xlAnd ' I列为第9列，筛选起始日符合要求的行
            .AutoFilter Field:=10, Criteria1:="<=" & CDbl(endDate), Operator:=xlAnd ' J列为第10列，筛选结束日符合要求的行
        End With
        
        ' 检查是否存在匹配的可见行
        On Error Resume Next
        Set visibleRng = srcSheet.Range("A9:MJ128").SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not visibleRng Is Nothing Then
            ' 复制可见行并粘贴值与格式
            visibleRng.Copy
            ThisWorkbook.Worksheets("Report Data").Range("A9").PasteSpecial xlPasteValues
            ThisWorkbook.Worksheets("Report Data").Range("A9").PasteSpecial xlFormats
            Application.CutCopyMode = False
        Else
            MsgBox "当前选择的日期范围内无匹配数据可导入"
        End If
        
        ' 清除源文件筛选后关闭，不修改源文件
        srcSheet.AutoFilterMode = False
        OpenBook.Close False
    End If
    
    ' 恢复屏幕刷新（修复原代码此处的错误配置）
    Application.ScreenUpdating = True
End Sub

核心修改说明 #

• 新增日期输入合法性校验，避免未填/错填日期时程序运行报错
• 新增AutoFilter筛选逻辑：按I列（周期起始日）≥输入起始日期、J列（周期结束日）≤输入结束日期的规则筛选数据
• 新增可见行判断逻辑，无匹配数据时主动提示，避免无数据可复制时触发程序异常
• 修复原代码末尾误将ScreenUpdating设为False的问题，程序结束后自动恢复Excel屏幕刷新
• 操作完成后自动清除源文件的筛选状态，不会修改源文件原有内容

适配说明 #

如果你的「Report Data」工作表表头不是第8行，可自行调整代码中srcSheet.Range("A8:MJ128")的行号参数，保证筛选范围包含表头行即可。

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