Excel VBA按用户输入双日期筛选表格及日期校验、数据复制方法

功能要求 #

实现逻辑：对Dados工作表中名为Dados的表格，按用户输入的起止日期（date1、date2）筛选后，将结果复制到Sheet2工作表。执行操作前需完成4项前置校验：

• 两个日期输入框均不能为空
• 输入内容必须为合法日期格式
• 起始日期不能大于结束日期
• 起始日期不能晚于系统当前日期
  校验通过后执行筛选复制，表格参考示例：
  

原有代码问题 #

初始编写的代码存在三类核心问题：

• 空值输入时触发错误13（类型不匹配）
• 变量传入筛选条件时无匹配结果
• 复制粘贴逻辑冗余，大量使用Select/Activate低效操作，还存在笔误（将xlDown写为x1Down）
  原有代码如下：

Option Explicit
Sub DateCheck()

Dim date1 As Date, date2 As Date, StartDate, EndDate

On Error GoTo Erro:

Dados.Activate
date1 = InputBox("Write the initial Date in format dd/mm/yyyy", "StartDate") '空值输入触发类型不匹配错误13
date2 = InputBox("Write the Final Date in format dd/mm/yyyy", "EndDate")

If date1 = "" Or date2 = "" Then
    Exit Sub
    End If
    
If Not IsDate(date1) Or Not IsDate(date2) Then
    MsgBox "Please enter a valid date format dd/mm/yyyy", vbCritical, "Invalid Date"
    
   ElseIf date1 > date2 Then

   MsgBox "The starter date must not be bigger than the final date ", vbCritical, "Invalid Date"
   ElseIf date1 > Date Then
   
    MsgBox "The starter Date must not be bigger than todays ", vbCritical, "Invalid Date"
   Else
    Dados.Activate
    StartDate = Format(DateValue(date1), "dd/mm/yyyy")
    EndDate = Format(DateValue(date2), "dd/mm/yyyy")
    Debug.Print StartDate
    Debug.Print EndDate
    
    ' 传入变量作为筛选条件无返回结果
      ActiveSheet.ListObjects("Dados").Range.AutoFilter Field:=3, _
                        Criteria1:=">=" & StartDate, _
                        Operator:=xlAnd, _
                        Criteria2:="<=" & EndDate
                        
     '冗余的复制粘贴逻辑
        Sheets("Sheet2").Select
        Range("C1").Select
        Range(Selection, Selection.End(xlToLeft)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Clear
        Sheets("Dados").Select
        Range("A2:C2").Select
        Range(Selection, Selection.End(x1Down)).Select
        Selection.Copy
        Sheets("Sheet2").Select
        Range ("A1")
        ActiveSheet.Paste
        

     
   End If
   
   
Erro:
MsgBox "Something is wrong, contact the SystemAdm", vbCritical, "Check"
End Sub

修复方案 #

对应问题修复逻辑 #

1. 解决类型不匹配错误：将输入接收变量改为Variant类型，先判断输入是否为空、是否为合法日期，校验通过后再转为日期类型，避免空值直接赋值给Date类型触发报错
2. 解决筛选无结果问题：VBA自动筛选识别日期条件时，统一使用mm/dd/yyyy格式的字符串传入条件，避免因系统区域日期格式差异导致匹配失败
3. 优化复制逻辑：移除所有不必要的Select/Activate操作，直接绑定列表对象操作，筛选后仅复制可见单元格，修正原有笔误；补充错误处理的退出逻辑，避免正常执行完成后仍触发通用错误提示

修复后完整代码 #

Option Explicit
Sub DateCheck()
    Dim wsDados As Worksheet, wsTarget As Worksheet
    Dim tblDados As ListObject
    Dim inputStart As Variant, inputEnd As Variant
    Dim date1 As Date, date2 As Date
    
    ' 直接绑定工作表和表格对象，无需反复激活选中
    Set wsDados = ThisWorkbook.Worksheets("Dados")
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
    Set tblDados = wsDados.ListObjects("Dados")
    
    On Error GoTo ErrHandler
    
    ' 获取用户输入
    inputStart = InputBox("请按dd/mm/yyyy格式输入起始日期", "起始日期")
    inputEnd = InputBox("请按dd/mm/yyyy格式输入结束日期", "结束日期")
    
    ' 非空校验
    If inputStart = "" Or inputEnd = "" Then
        MsgBox "日期输入不能为空，请重新输入", vbExclamation, "输入校验失败"
        GoTo ExitSub
    End If
    
    ' 日期格式合法性校验
    If Not IsDate(inputStart) Or Not IsDate(inputEnd) Then
        MsgBox "请输入合法的dd/mm/yyyy格式日期", vbCritical, "日期格式错误"
        GoTo ExitSub
    End If
    
    ' 校验通过后转换为日期类型
    date1 = CDate(inputStart)
    date2 = CDate(inputEnd)
    
    ' 日期范围校验：起始日期不大于结束日期
    If date1 > date2 Then
        MsgBox "起始日期不能大于结束日期，请重新输入", vbCritical, "日期范围错误"
        GoTo ExitSub
    End If
    
    ' 日期范围校验：起始日期不晚于当前系统日期
    If date1 > Date Then
        MsgBox "起始日期不能晚于系统当前日期，请重新输入", vbCritical, "日期范围错误"
        GoTo ExitSub
    End If
    
    ' 清空目标表旧数据
    wsTarget.Cells.Clear
    
    ' 清除表格原有筛选状态
    If tblDados.AutoFilter.FilterMode Then
        tblDados.AutoFilter.ShowAllData
    End If
    
    ' 执行日期筛选，统一用mm/dd/yyyy格式保证筛选条件识别正确
    tblDados.Range.AutoFilter _
        Field:=3, _
        Criteria1:=">=" & Format(date1, "mm/dd/yyyy"), _
        Operator:=xlAnd, _
        Criteria2:="<=" & Format(date2, "mm/dd/yyyy")
    
    ' 直接复制可见区域（表头+筛选后数据）到目标表，无需选中操作
    tblDados.Range.SpecialCells(xlCellTypeVisible).Copy wsTarget.Range("A1")
    
    ' 可选执行：取消Dados表的筛选状态
    ' tblDados.AutoFilter.ShowAllData
    
    MsgBox "数据筛选复制完成", vbInformation, "操作成功"

ExitSub:
    ' 释放对象内存
    Set tblDados = Nothing
    Set wsDados = Nothing
    Set wsTarget = Nothing
    Exit Sub

ErrHandler:
    MsgBox "运行出错，错误信息：" & Err.Description, vbCritical, "系统错误"
    Resume ExitSub
End Sub

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