如何在Excel VBA中按英式日期格式使用Date与Autofilter功能

问题背景 #

我编写了Excel VBA代码用于跨文件复制粘贴筛选后的数据，通过输入框获取起止日期，再用AutoFilter筛选列A的数据。但目前仅支持美式日期格式（mm/dd/yyyy）输入，英式日期（dd/mm/yyyy）无法正确筛选，需修改代码适配英式日期输入。

原代码 #

Sub MyFilter()
    
'define startdate & enddate & create msgbox
    Dim W1Startdate As Date, W1Enddate As Date
    Columns("A:A").Select
  
    Selection.NumberFormat = "dd/mm/yyyy"
    
    Range("A2").Select
    
    W1Startdate = Application.InputBox("Enter the Start Date in MM/DD/YYYY format")
    W1Enddate = Application.InputBox("Enter the End Date in MM/DD/YYYY format")
    
   
     
' base on startdate & end date to filter Column A
   ActiveSheet.Range("A1:E35").AutoFilter field:=1, Criteria1:=">=" & W1Startdate, Criteria2:="<=" & W1Enddate
   
' select & copy filtered column A information
   With ActiveSheet.AutoFilter.Range
    .Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy
   
   End With

' Paste filter column A to target file ("list2.xlsx") *change target file name when needed
    Windows("list2.xlsx").Activate
    Range("b" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste
    Windows("MASTER.xlsm").Activate
    
 ' select & copy filtered column B information
    With ActiveSheet.AutoFilter.Range
    .Offset(1, 1).Resize(.Rows.Count - 1, 1).Copy
    
    End With
   
 ' Paste filter column B to target file ("list2.xlsx") *change target file name when needed
    Windows("list2.xlsx").Activate
    Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste
    Windows("MASTER.xlsm").Activate
   
 ' select & copy filtered column 3 information
    With ActiveSheet.AutoFilter.Range
    .Offset(1, 2).Resize(.Rows.Count - 1, 1).Copy
    
    End With
   
 ' Paste filter column C to target file ("list2.xlsx") *change target file name when needed
    Windows("list2.xlsx").Activate
    Range("C" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste
    Windows("MASTER.xlsm").Activate
   
 ' select & copy filtered column 3 information
    With ActiveSheet.AutoFilter.Range
    .Offset(1, 4).Resize(.Rows.Count - 1, 1).Copy
    
    End With
   
 ' Paste filter column E to target file ("list2.xlsx") *change target file name when needed
    Windows("list2.xlsx").Activate
    Range("D" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste
    Windows("MASTER.xlsm").Activate
   
   
   
End Sub

修改方案 #

核心问题是VBA默认的日期解析逻辑和AutoFilter的日期条件格式要求不匹配，以下是可靠的修改方式：

修改后的完整代码

Sub MyFilter_Fixed()
    Dim W1Startdate As Date, W1Enddate As Date
    Dim startInput As String, endInput As String
    Dim dayPart As Integer, monthPart As Integer, yearPart As Integer
    
    ' 设置列A的显示格式（不影响实际日期值）
    Columns("A:A").NumberFormat = "dd/mm/yyyy"
    
    ' 获取用户输入，明确提示英式格式，强制输入字符串避免自动解析错误
    startInput = Application.InputBox("Enter the Start Date in DD/MM/YYYY format", Type:=2)
    endInput = Application.InputBox("Enter the End Date in DD/MM/YYYY format", Type:=2)
    
    ' 解析英式日期字符串，用DateSerial构造标准日期值
    On Error Resume Next
    dayPart = CInt(Split(startInput, "/")(0))
    monthPart = CInt(Split(startInput, "/")(1))
    yearPart = CInt(Split(startInput, "/")(2))
    W1Startdate = DateSerial(yearPart, monthPart, dayPart)
    
    dayPart = CInt(Split(endInput, "/")(0))
    monthPart = CInt(Split(endInput, "/")(1))
    yearPart = CInt(Split(endInput, "/")(2))
    W1Enddate = DateSerial(yearPart, monthPart, dayPart)
    On Error GoTo 0
    
    ' 校验日期有效性，无效则提示退出
    If IsDate(W1Startdate) = False Or IsDate(W1Enddate) = False Then
        MsgBox "Invalid date format! Please use DD/MM/YYYY.", vbExclamation
        Exit Sub
    End If
    
    ' 执行筛选：将日期转为序列号，AutoFilter可准确识别
    ActiveSheet.Range("A1:E35").AutoFilter Field:=1, Criteria1:=">=" & CLng(W1Startdate), _
        Operator:=xlAnd, Criteria2:="<=" & CLng(W1Enddate)
    
    ' 优化复制粘贴逻辑：直接引用目标工作表，减少窗口切换
    Dim targetWs As Worksheet
    Set targetWs = Workbooks("list2.xlsx").ActiveSheet
    
    ' 复制列A到目标列B
    With ActiveSheet.AutoFilter.Range
        .Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _
            targetWs.Range("B" & targetWs.Rows.Count).End(xlUp).Offset(1)
        ' 复制列B到目标列A
        .Offset(1, 1).Resize(.Rows.Count - 1, 1).Copy _
            targetWs.Range("A" & targetWs.Rows.Count).End(xlUp).Offset(1)
        ' 复制列C到目标列C
        .Offset(1, 2).Resize(.Rows.Count - 1, 1).Copy _
            targetWs.Range("C" & targetWs.Rows.Count).End(xlUp).Offset(1)
        ' 复制列E到目标列D
        .Offset(1, 4).Resize(.Rows.Count - 1, 1).Copy _
            targetWs.Range("D" & targetWs.Rows.Count).End(xlUp).Offset(1)
    End With
    
    ' 可选：清除筛选状态
    ActiveSheet.AutoFilterMode = False
End Sub

关键修改说明 #

• 输入框添加Type:=2强制获取字符串输入，避免VBA自动按美式格式解析日期
• 用DateSerial拆分构造日期值，彻底摆脱系统区域设置依赖，是跨区域场景最可靠的方案
• 筛选条件中用CLng()将日期转为序列号，AutoFilter能精准识别，避免字符串拼接导致的格式混乱
• 优化复制粘贴逻辑，直接引用目标工作表，减少频繁窗口切换，提升代码运行效率

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