合并VBA代码时出现运行时错误13（类型不匹配）怎么解决？

错误根源 #

高亮行For i = 2 To UBound(myarr)报错，核心原因是myarr并非始终是数组：

• 当待拆分的列所有值唯一（或处理后只剩1种唯一值）时，ws.Columns(icol).SpecialCells(xlCellTypeConstants)返回单个单元格，Transpose后得到的是单个值而非数组，UBound函数无法对单个值使用，触发类型不匹配错误。
• 原代码中On Error Resume Next掩盖了Match函数的查找错误，可能导致唯一值收集不完整，进一步引发后续逻辑异常。

修复方案 #

1. 增加数组判断逻辑，确保myarr始终为数组类型
2. 替换Application.WorksheetFunction.Match为Application.Match，避免依赖错误抑制语句
3. 移除不必要的Select操作，提升代码执行效率

修复后的完整代码 #

Sub Assessments_Clean_1()
    Dim ws As Worksheet, rng As Range
    Dim Last As Long, lr As Long, icol As Long, vcol As Long
    Dim myarr As Variant, title As String, titlerow As Integer
    Dim i As Long, matchResult As Variant
    
    ' 处理A列格式
    With ActiveSheet.Columns("A:A")
        .NumberFormat = "General"
        .Value = .Value
    End With
    
    ' 删除指定列
    ActiveSheet.Columns("D:D").Delete Shift:=xlToLeft
    ActiveSheet.Columns("D:D").Delete Shift:=xlToLeft
    ActiveSheet.Columns("F:F").Delete Shift:=xlToLeft
    
    ' 插入G列并设置公式
    ActiveSheet.Columns("G:G").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    ActiveSheet.Range("G1").Value = "Next Step"
    ActiveSheet.Range("G2").FormulaR1C1 = _
        "=IF(RC[-1]="""",""Assessments_Clean_2"",IF(RC[-1]<DATE(2023,7,1),""Delete"",IF(RC[-1]>=DATE(2023,7,1),""Completed_Orig"")))"
    
    ' 填充公式并转为值
    Set ws = ActiveSheet
    Set rng = ws.Range("G2:G" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
    ws.Range("G2").AutoFill Destination:=rng
    ws.Cells.Copy
    ws.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    ' 删除标记为Delete的行
    Last = ws.Cells(Rows.Count, "G").End(xlUp).Row
    For i = Last To 1 Step -1
        If ws.Cells(i, "G").Value = "Delete" Then
            ws.Cells(i, "A").EntireRow.Delete
        End If
    Next i
    
    Application.ScreenUpdating = False
    
    ' 获取筛选列
    vcol = Application.InputBox(prompt:="请选择筛选的列号", title:="筛选列", Default:="1", Type:=1)
    
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    
    ' 收集唯一值（替换WorksheetFunction.Match为Application.Match，避免On Error）
    For i = 2 To lr
        If ws.Cells(i, vcol) <> "" Then
            matchResult = Application.Match(ws.Cells(i, vcol), ws.Columns(icol), 0)
            If IsError(matchResult) Then
                ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
            End If
        End If
    Next
    
    ' 处理myarr，确保为数组
    On Error Resume Next
    Set rng = ws.Columns(icol).SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    
    If rng Is Nothing Then
        ' 无唯一值（理论上不会出现，因为至少有标题行）
        MsgBox "未找到可拆分的唯一值"
        GoTo Cleanup
    Else
        If rng.Cells.Count = 1 Then
            ' 单个值转为单元素数组
            myarr = Array(rng.Value)
        Else
            myarr = Application.WorksheetFunction.Transpose(rng)
        End If
    End If
    
    ws.Columns(icol).Clear
    
    ' 拆分工作表
    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i)
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i)
        Else
            Sheets(myarr(i)).Move after:=Worksheets(Worksheets.Count)
        End If
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i)).Range("A1")
        'Sheets(myarr(i)).Columns.AutoFit
    Next
    
Cleanup:
    ws.AutoFilterMode = False
    ws.Activate
    Application.ScreenUpdating = True
End Sub

关键修复点说明 #

• 数组安全处理：通过判断SpecialCells返回的单元格数量，将单个值转为数组，避免UBound报错
• 错误处理优化：用Application.Match替代WorksheetFunction.Match，结合IsError判断匹配结果，移除危险的On Error Resume Next
• 效率提升：删除所有不必要的Select操作，直接操作对象，减少Excel界面交互开销

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