高级筛选报错：替换文本为日期时触发VBA运行时错误1004

问题现象 #

原VBA代码在表头为文本（如date 1、date 2）时运行正常，但将表头替换为实际日期（源自其他工作表/数据透视表）或跨表引用日期的公式后，执行以下语句触发Runtime Error 1004：

ShtSource.Range("A13").CurrentRegion.AdvancedFilter xlFilterCopy, CriteriaRange, CopyToRange

完整代码如下：

Sub Proposal()
    
    ' voorstel om door te sturen naar de klant
    
    Dim c As Range
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Dim ShtSource As Worksheet: Set ShtSource = ThisWorkbook.Sheets("Voorstel")
    Dim CopyToRange As Range: Set CopyToRange = Workbooks.Add.Sheets(1).Range("A1").Resize(2, 6)
    Dim CriteriaRange As Range: Set CriteriaRange = CopyToRange.Offset(, 8).Resize(2, 1)
    
    CopyToRange.Resize(1) = Array(ShtSource.[a13], ShtSource.[b13], ShtSource.[d13], ShtSource.[f13], ShtSource.[h13], ShtSource.[j13])
    CriteriaRange.Value = Application.Transpose(Array("# Pal", "<>0"))
    ShtSource.Range("A13").CurrentRegion.AdvancedFilter xlFilterCopy, CriteriaRange, CopyToRange
    
    CriteriaRange.ClearContents
    
    Application.DisplayAlerts = True
    
    Range("A1").Select
    Range("A1").Activate
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15773696
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Range("B1:F1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 49407
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Columns("A:G").Select
    Range("A1").Activate
    Columns("A:G").EntireColumn.AutoFit
    Range("A1").Select
    
End Sub

已尝试调整日期格式，问题仍未解决。

核心原因与解决思路 #

1. 表头数据类型不匹配（最可能） #

高级筛选要求CopyToRange的表头必须与数据源表头完全一致，包括数据类型。原代码用Array()批量赋值时，会将日期类型的表头自动转换为文本类型，导致Excel无法匹配数据源的日期表头，触发报错。

解决方法：

• 方式1：逐个单元格赋值，保留原始数据类型
  将原代码中CopyToRange.Resize(1) = Array(...)替换为：

  With CopyToRange.Resize(1)
      .Cells(1).Value = ShtSource.Range("A13").Value
      .Cells(2).Value = ShtSource.Range("B13").Value
      .Cells(3).Value = ShtSource.Range("D13").Value
      .Cells(4).Value = ShtSource.Range("F13").Value
      .Cells(5).Value = ShtSource.Range("H13").Value
      .Cells(6).Value = ShtSource.Range("J13").Value
  End With
  

• 方式2：先匹配单元格格式，再赋值

  ' 先同步数据源表头的格式
  CopyToRange.Resize(1).NumberFormat = ShtSource.Range("A13,B13,D13,F13,H13,J13").NumberFormat
  ' 再赋值
  CopyToRange.Resize(1) = Array(ShtSource.[a13], ShtSource.[b13], ShtSource.[d13], ShtSource.[f13], ShtSource.[h13], ShtSource.[j13])
  

2. CurrentRegion识别异常 #

当表头为日期或公式时，Excel可能误判CurrentRegion的边界（比如公式返回空值、格式差异导致区域识别错误），导致高级筛选的数据源范围不正确。

解决方法：手动指定数据源范围，替代CurrentRegion：

' 计算数据源的最后一行和最后一列
Dim lastRow As Long, lastCol As Long
lastRow = ShtSource.Cells(ShtSource.Rows.Count, "A").End(xlUp).Row
lastCol = ShtSource.Cells(13, ShtSource.Columns.Count).End(xlToLeft).Column
' 明确数据源范围
Dim dataRange As Range: Set dataRange = ShtSource.Range(ShtSource.Cells(13, 1), ShtSource.Cells(lastRow, lastCol))
' 用明确的范围执行高级筛选
dataRange.AdvancedFilter xlFilterCopy, CriteriaRange, CopyToRange

3. 日期格式区域冲突 #

系统日期格式与单元格显示格式不一致时，Excel内部存储的日期序列号可能与显示值不匹配，导致表头匹配失败。

解决方法：用Value2直接读取单元格原始数值（日期的序列号），避免格式干扰：

With CopyToRange.Resize(1)
    .Cells(1).Value2 = ShtSource.Range("A13").Value2
    .Cells(2).Value2 = ShtSource.Range("B13").Value2
    .Cells(3).Value2 = ShtSource.Range("D13").Value2
    .Cells(4).Value2 = ShtSource.Range("F13").Value2
    .Cells(5).Value2 = ShtSource.Range("H13").Value2
    .Cells(6).Value2 = ShtSource.Range("J13").Value2
End With

修改后的完整示例代码 #

Sub Proposal()
    
    ' voorstel om door te sturen naar de klant
    
    Dim c As Range
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Dim ShtSource As Worksheet: Set ShtSource = ThisWorkbook.Sheets("Voorstel")
    Dim CopyToRange As Range: Set CopyToRange = Workbooks.Add.Sheets(1).Range("A1").Resize(2, 6)
    Dim CriteriaRange As Range: Set CriteriaRange = CopyToRange.Offset(, 8).Resize(2, 1)
    
    ' 替换原Array赋值，保留日期数据类型
    With CopyToRange.Resize(1)
        .Cells(1).Value = ShtSource.Range("A13").Value
        .Cells(2).Value = ShtSource.Range("B13").Value
        .Cells(3).Value = ShtSource.Range("D13").Value
        .Cells(4).Value = ShtSource.Range("F13").Value
        .Cells(5).Value = ShtSource.Range("H13").Value
        .Cells(6).Value = ShtSource.Range("J13").Value
    End With
    
    CriteriaRange.Value = Application.Transpose(Array("# Pal", "<>0"))
    
    ' 手动指定数据源范围，替代CurrentRegion
    Dim lastRow As Long, lastCol As Long
    lastRow = ShtSource.Cells(ShtSource.Rows.Count, "A").End(xlUp).Row
    lastCol = ShtSource.Cells(13, ShtSource.Columns.Count).End(xlToLeft).Column
    Dim dataRange As Range: Set dataRange = ShtSource.Range(ShtSource.Cells(13, 1), ShtSource.Cells(lastRow, lastCol))
    dataRange.AdvancedFilter xlFilterCopy, CriteriaRange, CopyToRange
    
    CriteriaRange.ClearContents
    
    Application.DisplayAlerts = True
    
    Range("A1").Select
    Range("A1").Activate
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15773696
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Range("B1:F1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 49407
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Columns("A:G").Select
    Range("A1").Activate
    Columns("A:G").EntireColumn.AutoFit
    Range("A1").Select
    
End Sub

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