VBA实现日期范围匹配并复制整行功能的问题排查

问题背景 #

我有一份产品过期日志文件，通过制造商提供的日期及「有效过期日期（Effective Expiration Date）」追踪产品过期情况。每年的数据对应独立工作表（如2022、2023），每个工作表里都有一个前缀为下划线的同名表格（如_2022、_2023）。我需要开发VBA宏，遍历当前及未来两年的表格，筛选出「有效过期日期」在今日至一周内的行，复制到宏新建的「Weekly Exp」工作表中。

我写了如下代码，但运行3-5分钟后会报「Type Mismatch（类型不匹配）」错误，而且没有内容被复制；用MsgBox测试时还发现日期匹配范围异常，比如匹配到了2022年12月31日的日期。目前日期获取、工作表检测与创建功能是正常的。

原代码 #

Sub weeklyExpirationSheet()
    Dim dtToday As Date
    Dim dtWeekOut As Date
    Dim dtEffExp As Date
    Dim dtTest As Date
    Dim theYear As String
    Dim countDays As Long
    Dim ws As Worksheet
    Dim srcSheet As Worksheet
    Dim destSheet As Worksheet
    Dim srcTable As ListObject
    Dim srcRow As Range
    
    dtToday = Date
    dtWeekOut = DateAdd("ww", 1, dtToday)
    countDays = DateDiff("d", dtToday, dtWeekOut)
    
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name = "Weekly Exp" Then
            MsgBox "Weekly Audit Sheet Already Exists!"
            Exit Sub
        End If
    Next ws
    
    Sheets.Add(After:=Sheets("Incoming")).Name = "Weekly Exp"
    Set destSheet = Worksheets("Weekly Exp")
    
    With destSheet
    
        Range("A1").Value = "UPC"
        Range("B1").Value = "Brand"
        Range("C1").Value = "Product"
        Range("D1").Value = "Sz"
        Range("E1").Value = "Expr"
        Range("F1").Value = "Eff Exp"
        Range("G1").Value = "Qty"
        Range("H1").Value = "Location"

        dtCurrentYear = CDbl(Year(Date))
        dtEndYear = CDbl(dtCurrentYear + 2)
        
        For y = dtCurrentYear To dtEndYear
            Set srcSheet = Worksheets(CStr(y))
            Set srcTable = srcSheet.ListObjects("_" & CStr(y))
            
            With srcSheet
                LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
                For p = 2 To LastRow
                    dtTest = .Cells(p, "F").Value
                    If dtTest >= dtToday And dtTest <= dtWeekOut Then
                        destLastRow = destSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
                        Rows(p).Copy Destination:=destSheet.Rows(destLastRow)
                    End If
                Next p
            End With
        Next y
    
    End With
End Sub

问题分析 #

• 类型不匹配错误：直接将单元格值赋值给Date类型变量dtTest，若单元格存在空值、文本等非日期数据，会触发类型不匹配。
• 日期匹配异常：遍历的是工作表整列的行，而非目标ListObject表格，容易读取到表格外的无效日期；且未判断单元格值是否为有效日期。
• 运行效率低下：逐行遍历复制的方式导致宏运行缓慢，耗时久。

修复后的代码 #

Sub weeklyExpirationSheet()
    Dim dtToday As Date
    Dim dtWeekOut As Date
    Dim ws As Worksheet
    Dim srcSheet As Worksheet
    Dim destSheet As Worksheet
    Dim srcTable As ListObject
    Dim filteredRows As Range
    Dim destLastRow As Long
    Dim currentYear As Long
    Dim endYear As Long
    
    ' 初始化日期范围
    dtToday = Date
    dtWeekOut = DateAdd("ww", 1, dtToday)
    
    ' 检查目标工作表是否已存在
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name = "Weekly Exp" Then
            MsgBox "Weekly Audit Sheet Already Exists!"
            Exit Sub
        End If
    Next ws
    
    ' 创建并设置目标工作表
    Set destSheet = Sheets.Add(After:=Sheets("Incoming"))
    destSheet.Name = "Weekly Exp"
    ' 设置表头
    With destSheet.Range("A1:H1")
        .Value = Array("UPC", "Brand", "Product", "Sz", "Expr", "Eff Exp", "Qty", "Location")
        .Font.Bold = True
    End With
    
    ' 设置遍历的年份范围（当前年至未来两年）
    currentYear = Year(Date)
    endYear = currentYear + 2
    
    ' 遍历目标年份工作表
    For currentYear = currentYear To endYear
        ' 检查工作表是否存在，避免报错
        On Error Resume Next
        Set srcSheet = Worksheets(CStr(currentYear))
        On Error GoTo 0
        If srcSheet Is Nothing Then
            MsgBox "工作表 " & currentYear & " 不存在，跳过！"
            Set srcSheet = Nothing
            GoTo NextYear
        End If
        
        ' 获取对应ListObject表格
        On Error Resume Next
        Set srcTable = srcSheet.ListObjects("_" & CStr(currentYear))
        On Error GoTo 0
        If srcTable Is Nothing Then
            MsgBox "工作表 " & currentYear & " 中表格 _" & currentYear & " 不存在，跳过！"
            Set srcTable = Nothing
            GoTo NextYear
        End If
        
        ' 清除表格原有筛选
        If srcTable.AutoFilter.FilterMode Then srcTable.AutoFilter.ShowAllData
        
        ' 筛选有效过期日期在今日至一周内的行
        With srcTable.ListColumns("Eff Exp").Range
            .AutoFilter Field:=1, Criteria1:=">=" & CLng(dtToday), _
                        Operator:=xlAnd, Criteria2:="<=" & CLng(dtWeekOut)
        End With
        
        ' 获取筛选后的可见数据行（排除表头）
        On Error Resume Next
        Set filteredRows = srcTable.DataBodyRange.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        ' 复制筛选结果到目标工作表
        If Not filteredRows Is Nothing Then
            destLastRow = destSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
            filteredRows.Copy Destination:=destSheet.Cells(destLastRow, "A")
        End If
        
        ' 重置对象，进入下一年循环
NextYear:
        Set srcSheet = Nothing
        Set srcTable = Nothing
        Set filteredRows = Nothing
    Next currentYear
    
    ' 自动调整目标工作表列宽
    destSheet.Columns("A:H").AutoFit
    MsgBox "筛选完成，结果已保存至 Weekly Exp 工作表！"
End Sub

关键修改说明 #

1. 增加错误处理：检查年份工作表和对应表格是否存在，避免因缺失对象报错。
2. 使用ListObject筛选：利用表格的自动筛选功能直接获取符合条件的行，替代逐行遍历，大幅提升效率。
3. 日期格式兼容：将日期转换为长整型（CLng）进行筛选，避免格式不兼容问题。
4. 仅复制有效数据：只复制表格的可见数据行，避免复制整行冗余内容。
5. 增加收尾处理：自动调整目标工作表列宽，完成后弹出提示。

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