VBA跨工作簿复制数据时出现Range类型不匹配(Type mismatch)错误

问题背景 #

这段VBA代码用于读取两个工作簿数据，根据单元格数值筛选后复制到目标工作簿。此前运行正常，修改后仅在处理第二个工作簿时触发**Type mismatch（类型不匹配）**错误，错误指向判断Status.Value > 31的代码行。

原代码 #

Dim StatusCol As Range
Dim StatusCol2 As Range
Dim Status As Range
Dim PasteCell As Range
Dim SCH22 As Workbook
Dim SCH21 As Workbook
Dim BD As Workbook

Set SCH22 = Workbooks.Open("path to first workbook")
Set SCH21 = Workbooks.Open("path to second workbook")
Set BD = Workbooks.Open("path to pasting workbook")

Set StatusCol = SCH22.Sheets("CONTFRM22-23").Range("T2:T5000")
Set StatusCol2 = SCH21.Sheets("CONTFRM20-21").Range("R2:R5000")

ThisWorkbook.Sheets("2022-23").Range("A2:AC5000").ClearContents
ThisWorkbook.Sheets("2020-21").Range("A2:R5000").ClearContents

For Each Status In StatusCol
    If BD.Sheets("2022-23").Range("A2") = "" Then
        Set PasteCell = BD.Sheets("2022-23").Range("A2")
    Else
        Set PasteCell = BD.Sheets("2022-23").Range("A1").End(xlDown).Offset(1, 0)
    End If
    
    If Status.Value > 31 Then Status.Offset(0, -19).Resize(1, 31).Copy PasteCell
    
Next Status

For Each Status In StatusCol2
    If BD.Sheets("2020-21").Range("A2") = "" Then
        Set PasteCell = BD.Sheets("2020-21").Range("A2")
    Else
        Set PasteCell = BD.Sheets("2020-21").Range("A1").End(xlDown).Offset(1, 0)
    End If
    
    If Status.Value > 31 Then Status.Offset(0, -17).Resize(1, 29).Copy PasteCell
    
Next Status

End Sub

错误信息 #

错误提示：Type mismatch
触发错误的代码行：

If Status.Value > 31 Then Status.Offset(0, -17).Resize(1, 29).Copy PasteCell

原因分析 #

类型不匹配的核心原因是：第二个工作簿的CONTFRM20-21工作表中，R2:R5000范围内存在非数值类型的单元格（比如文本、空值、错误值#N/A/#VALUE!等），直接和数值31比较时，VBA无法完成类型转换，从而抛出错误。第一个工作簿的T列单元格均为数值，因此无异常。

修复方案 #

方案1：先验证单元格是否为数值再比较 #

在判断前加入IsNumeric检查，过滤非数值单元格：

For Each Status In StatusCol2
    If BD.Sheets("2020-21").Range("A2") = "" Then
        Set PasteCell = BD.Sheets("2020-21").Range("A2")
    Else
        Set PasteCell = BD.Sheets("2020-21").Range("A1").End(xlDown).Offset(1, 0)
    End If
    
    ' 新增数值验证，避免类型不匹配
    If IsNumeric(Status.Value) And Status.Value > 31 Then
        Status.Offset(0, -17).Resize(1, 29).Copy PasteCell
    End If
Next Status

方案2：同时排除错误值 #

如果目标列存在公式错误值（如#N/A），需额外加入IsError判断：

For Each Status In StatusCol2
    If BD.Sheets("2020-21").Range("A2") = "" Then
        Set PasteCell = BD.Sheets("2020-21").Range("A2")
    Else
        Set PasteCell = BD.Sheets("2020-21").Range("A1").End(xlDown).Offset(1, 0)
    End If
    
    ' 排除错误值+验证数值类型
    If Not IsError(Status.Value) And IsNumeric(Status.Value) And Status.Value > 31 Then
        Status.Offset(0, -17).Resize(1, 29).Copy PasteCell
    End If
Next Status

额外优化：提升循环效率 #

原代码每次循环都重新查找粘贴位置，效率较低。可提前记录下一行行号，避免重复查找：

' 替换原第二个循环部分
Dim nextRow As Long
With BD.Sheets("2020-21")
    ' 找到A列最后一行的下一行
    nextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    ' 确保从A2开始（如果A列为空）
    If nextRow < 2 Then nextRow = 2
End With

For Each Status In StatusCol2
    If Not IsError(Status.Value) And IsNumeric(Status.Value) And Status.Value > 31 Then
        Status.Offset(0, -17).Resize(1, 29).Copy BD.Sheets("2020-21").Cells(nextRow, "A")
        nextRow = nextRow + 1 ' 粘贴后行号自增
    End If
Next Status

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