VBA实现同一Excel工作簿按日期范围跨表复制动态表格数据

适配后的VBA完整代码 #

Option Explicit

' 弹窗让用户输入起止日期
Public Sub PromptUserForInputDates()
    
    Dim strStart As String, strEnd As String, strPromptMessage As String
    
    ' 输入起始日期
    strStart = InputBox("请输入起始日期")
    
    ' 校验起始日期是否合法
    If Not IsDate(strStart) Then
        strPromptMessage = "输入的起始日期不合法，请重新输入有效日期！"
        MsgBox strPromptMessage
        Exit Sub
    End If
    
    ' 输入结束日期
    strEnd = InputBox("请输入结束日期")
    
    ' 校验结束日期是否合法
    If Not IsDate(strEnd) Then
        strPromptMessage = "输入的结束日期不合法，请重新输入有效日期！"
        MsgBox strPromptMessage
        Exit Sub
    End If
    
    ' 调用筛选复制的子过程
    Call FilterAndCopyData(strStart, strEnd)
    
End Sub

' 筛选Tab1符合日期范围的数据并粘贴到Tab2
Public Sub FilterAndCopyData(StartDate As String, EndDate As String)
    
    Dim wksSource As Worksheet, wksTarget As Worksheet
    Dim lngLastRow As Long, lngLastCol As Long
    Dim rngFull As Range, rngResult As Range
    
    ' 配置源表和目标表，若你的工作表名称不是Tab1/Tab2请修改此处
    Set wksSource = ThisWorkbook.Worksheets("Tab1")
    Set wksTarget = ThisWorkbook.Worksheets("Tab2")
    
    ' 先清空目标表C8开始的旧数据
    wksTarget.Range("C8").CurrentRegion.ClearContents
    
    ' 获取源表数据范围（从C8开始的有效数据）
    With wksSource
        lngLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
        ' 若源表C8以下没有数据直接退出
        If lngLastRow < 8 Then
            MsgBox "源表Tab1 C8以下无有效数据"
            Exit Sub
        End If
        lngLastCol = .Cells(8, .Columns.Count).End(xlToLeft).Column
        Set rngFull = .Range(.Cells(8, "C"), .Cells(lngLastRow, lngLastCol))
    End With
    
    ' 按日期范围筛选
    With rngFull
        .AutoFilter Field:=1, _
                    Criteria1:=">=" & CLng(CDate(StartDate)), _
                    Criteria2:="<=" & CLng(CDate(EndDate))
                    
        ' 捕获筛选后的可见单元格，处理无符合数据的情况
        On Error Resume Next
        Set rngResult = .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If rngResult Is Nothing Then
            MsgBox "所选日期范围内没有匹配的数据"
        Else
            ' 复制可见单元格到目标表C8位置
            rngResult.Copy Destination:=wksTarget.Range("C8")
            MsgBox "数据提取完成！"
        End If
        
        ' 清除源表筛选
        wksSource.AutoFilterMode = False
        If wksSource.FilterMode = True Then
            wksSource.ShowAllData
        End If
    End With

End Sub

关键调整说明 #

• 修复了原代码结束日期校验的逻辑错误（原代码结束日期校验仍判断起始日期变量）
• 移除了新建工作簿的逻辑，直接操作当前工作簿的Tab1（源表）和Tab2（目标表）
• 适配数据范围规则：仅读取Tab1 C8开始的有效数据，筛选后直接粘贴到Tab2的C8位置，粘贴前会自动清空Tab2的旧数据
• 增加了空数据、无匹配数据的异常处理，避免代码运行报错
• 日期筛选统一转换为数值对比，适配日/月/年的日期格式，不会出现格式不匹配导致的筛选错误

补充说明：如果需要同时复制Tab1中A、B列的内容，将Set rngFull = .Range(.Cells(8, "C"), .Cells(lngLastRow, lngLastCol))修改为Set rngFull = .Range(.Cells(8, "A"), .Cells(lngLastRow, lngLastCol))，同时将Field:=1修改为Field:=3即可。

界面示例 #

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