VBA获取单元格日期值传递至筛选器失败问题求助

问题背景 #

• 电子表格Bi-Hourly Report的A列通过递归公式（上方单元格+1）自动填充日期，每行对应一条数据
• 需求：读取EOS工作表B2单元格的日期，筛选出对应日期的12行数据，粘贴到Report工作表；后续需整合其他筛选/打印逻辑，通过按钮触发
• 当前问题：
  • 第一个循环宏中，MsgBox显示日期为12:00 AM，无法正确展示实际日期
  • 使用Date类型变量时，第二个宏的AdvancedFilter直接失效
  • 第二个宏用字符串类型接收日期值，虽能获取部分数据，但结果不符合需求

现有尝试代码 #

宏1：循环复制 #

Sub For_RangeCopy()
    Dim rDate As Date
    Dim rSheet As Worksheet
    Set rSheet = ThisWorkbook.Worksheets("EOS")
    rDate = CDate(rSheet.Range("B2").Value)
    MsgBox (rDate)
    ' Get the worksheets
    Dim shRead As Worksheet
    Set shRead = ThisWorkbook.Worksheets("Bi-Hourly Report")
    
    Dim shWrite As Worksheet
    Set shWrite = ThisWorkbook.Worksheets("Report")
    
    ' Get the range
    Dim rg As Range
    Set rg = shRead.Range("A1").CurrentRegion
    
    With shWrite

        ' Clear the data in output worksheet
        .Cells.ClearContents
        
        ' Set the cell formats
        '.Columns(1).NumberFormat = "dd/mm/yyyy"
        '.Columns(3).NumberFormat = "$#,##0;[Red]$#,##0"
        '.Columns(4).NumberFormat = "0"
        '.Columns(5).NumberFormat = "$#,##0;[Red]$#,##0"
        
    End With
    
    ' Read through the data
    Dim i As Long, row As Long
    row = 1
    For i = 1 To rg.Rows.Count
        
        If rg.Cells(i, 1).Value2 = rDate Or i = 1 Then
            
            ' Copy using Range.Copy
            rg.Rows(i).Copy
            shWrite.Range("A" & row).PasteSpecial xlPasteValues
            
            ' move to the next output row
            row = row + 1
            
        End If
        
    Next i
    
End Sub

宏2：高级筛选 #

Sub AdvancedFilterExample()
    ' Get the worksheets
    Dim rSheet As Worksheet
    Set rSheet = ThisWorkbook.Worksheets("EOS")
    Dim shRead As Worksheet, shWrite As Worksheet
    Set shRead = ThisWorkbook.Worksheets("Bi-Hourly Report")
    Set shWrite = ThisWorkbook.Worksheets("Report")
    
    ' Clear any existing data
    shWrite.Cells.Clear

    ' Remove the any existing filters
    If shRead.FilterMode = True Then
        shRead.ShowAllData
    End If
    
    ' Get the source data range
    Dim rgData As Range, rgCriteria As String
    Set rgData = shRead.Range("A1").CurrentRegion
    
    ' IMPORTANT: Do not have any blank rows in the criteria range
    'Set rgCriteria = rSheet.Range("B2")
    rgCriteria = rSheet.Range("B2").Value
    MsgBox (rgCriteria)
   
    ' Apply the filter
    rgData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rgCriteria _
                , CopyToRange:=shWrite.Range("A1")

 End Sub

问题根源 #

1. 日期显示异常：Date类型变量在MsgBox中默认只显示时间部分（当日期为纯整数时，时间为0，即12:00 AM），需手动格式化输出
2. AdvancedFilter失效：AdvancedFilter的CriteriaRange参数要求传入单元格区域，而非单个值；且条件区域必须包含与源表一致的表头文本，否则无法匹配
3. 日期匹配误差：直接对比Value2和Date变量，可能因单元格格式或隐藏时间戳导致匹配失败

解决方案 #

方案1：优化循环筛选（逻辑直观，适合小数据量） #

修正日期匹配逻辑，格式化日期显示，处理合并表头：

Sub Optimized_RangeCopy()
    Dim targetDate As Date
    Dim wsEOS As Worksheet, wsSource As Worksheet, wsReport As Worksheet
    
    ' 初始化工作表对象
    Set wsEOS = ThisWorkbook.Worksheets("EOS")
    Set wsSource = ThisWorkbook.Worksheets("Bi-Hourly Report")
    Set wsReport = ThisWorkbook.Worksheets("Report")
    
    ' 提取纯日期部分，避免时间干扰
    targetDate = DateValue(wsEOS.Range("B2").Value)
    MsgBox "目标筛选日期：" & Format(targetDate, "yyyy/mm/dd") ' 格式化显示日期
    
    ' 清空Report工作表
    wsReport.Cells.ClearContents
    
    ' 复制合并表头（1-3行，按需调整范围）
    wsSource.Range("A1:C3").Copy
    wsReport.Range("A1").PasteSpecial xlPasteAll ' 保留合并格式
    
    ' 定义源数据区域（跳过前3行表头，从第4行开始）
    Dim sourceRange As Range
    Set sourceRange = wsSource.Range("A4").CurrentRegion
    
    Dim rowIndex As Long, outputRow As Long
    outputRow = 4 ' 数据从表头下一行开始
    
    ' 循环匹配日期
    For rowIndex = 1 To sourceRange.Rows.Count
        ' 提取当前单元格的纯日期部分进行匹配
        If DateValue(sourceRange.Cells(rowIndex, 1).Value2) = targetDate Then
            sourceRange.Rows(rowIndex).Copy
            wsReport.Range("A" & outputRow).PasteSpecial xlPasteValues
            outputRow = outputRow + 1
        End If
    Next rowIndex
    
    ' 清除剪贴板，避免弹窗提示
    Application.CutCopyMode = False
End Sub

方案2：AdvancedFilter优化（高效，适合大数据量） #

创建临时条件区域，匹配源表表头格式，解决筛选失效问题：

Sub AdvancedFilter_Fixed()
    Dim targetDate As Date
    Dim wsEOS As Worksheet, wsSource As Worksheet, wsReport As Worksheet, wsTemp As Worksheet
    
    ' 初始化工作表
    Set wsEOS = ThisWorkbook.Worksheets("EOS")
    Set wsSource = ThisWorkbook.Worksheets("Bi-Hourly Report")
    Set wsReport = ThisWorkbook.Worksheets("Report")
    
    ' 获取目标日期（纯日期部分）
    targetDate = DateValue(wsEOS.Range("B2").Value)
    
    ' 清空Report工作表
    wsReport.Cells.Clear
    
    ' 移除源表现有筛选
    If wsSource.FilterMode Then wsSource.ShowAllData
    
    ' 创建临时工作表存放条件区域
    On Error Resume Next
    Set wsTemp = ThisWorkbook.Worksheets("TempCriteria")
    If Err.Number <> 0 Then
        Set wsTemp = ThisWorkbook.Worksheets.Add
        wsTemp.Name = "TempCriteria"
    End If
    On Error GoTo 0
    
    ' 设置条件区域：第一行是源表A列的表头文本，第二行是目标日期
    wsTemp.Range("A1").Value = wsSource.Range("A1").Value ' 匹配源表表头
    wsTemp.Range("A2").Value = targetDate
    wsTemp.Range("A2").NumberFormat = wsSource.Range("A4").NumberFormat ' 匹配源表日期格式
    
    ' 定义源数据区域（包含第3行作为筛选表头，按需调整）
    Dim sourceData As Range
    Set sourceData = wsSource.Range("A3").CurrentRegion
    
    ' 执行高级筛选
    sourceData.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=wsTemp.Range("A1:A2"), _
        CopyToRange:=wsReport.Range("A1"), _
        Unique:=False
    
    ' 删除临时工作表
    Application.DisplayAlerts = False
    wsTemp.Delete
    Application.DisplayAlerts = True
    
    ' 还原合并表头（按需调整范围）
    wsReport.Range("A1:C3").Merge
End Sub

关键注意事项 #

• 表头匹配：AdvancedFilter的条件区域表头必须和源表筛选列的表头文本完全一致，否则无法识别
• 日期处理：始终用DateValue()提取纯日期部分，避免因单元格格式或隐藏时间戳导致的匹配失败
• 大数据量优先：每年约4380行数据，AdvancedFilter的效率远高于循环遍历
• OneDrive兼容：确保工作簿启用宏，且OneDrive同步完成后再执行宏，避免文件锁定

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