VBA运行时错误'13'（日期≥10触发）：如何实现整月稳定运行？

• 场景：在InitialWorkbook.xlsm中编写VBA宏，从KPITool.xlsm的D2:F2区域复制数据，根据C2单元格的日期粘贴到对应行
• 故障现象：每月1-9日运行正常，日期≥10时触发运行时错误'13'（类型不匹配）
• 背景：因GDPR合规要求，需将数据存储在独立工作簿，避免其他部门看到输入信息

原代码：

Sub PasteKPI()
    Application.ScreenUpdating = True
    'OpenWorkbook1
    Dim ws As Worksheet: Set ws = Workbooks("KPITool.xlsm").Worksheets("KPITotal")
    With ws
        .Range("D2:F2").Copy
        Dim sDate As String: sDate = .Range("C2").Value
        Dim srcDate As Date: srcDate = CDate(Right(sDate, Len(sDate) - InStr(sDate, ",") - 1))
        Dim srcRange As Range: Set srcRange = .Cells.Find(srchDate)
        If Not srcRange Is Nothing Then
            srcRange.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    End With
    Application.CutCopyMode = True
    CloseWorkbook1
    Workbooks("InitialWorkbook.xlsm").RefreshAll
End Sub

1. 变量名拼写错误：定义了srcDate，但Find方法中使用未声明的srchDate，导致变量被识别为Variant类型，日期为两位数时触发类型不匹配
2. 日期处理逻辑脆弱：将日期值转为字符串后截取，依赖单元格显示格式（如是否带星期逗号），格式变化时易出错
3. 状态设置错误：Application.ScreenUpdating = True违背宏优化逻辑，Application.CutCopyMode = True未正确清除复制状态
4. 缺少错误处理：未捕获异常，出错后无法恢复Excel正常状态

Sub PasteKPI()
    Application.ScreenUpdating = False
    On Error GoTo Cleanup ' 确保出错时恢复状态
    
    Dim kpiWB As Workbook
    Set kpiWB = Workbooks("KPITool.xlsm")
    Dim ws As Worksheet
    Set ws = kpiWB.Worksheets("KPITotal")
    
    With ws
        ' 直接读取日期值，避免字符串截取的脆弱逻辑
        Dim targetDate As Date
        targetDate = .Range("C2").Value
        
        ' 精准查找日期，指定匹配规则
        Dim srcRange As Range
        Set srcRange = .Cells.Find(What:=targetDate, _
                                   LookIn:=xlValues, _
                                   LookAt:=xlWhole, _
                                   MatchCase:=False)
        
        If Not srcRange Is Nothing Then
            ' 直接赋值替代复制粘贴，更高效稳定
            srcRange.Offset(0, 1).Resize(1, 3).Value = .Range("D2:F2").Value
        Else
            MsgBox "未找到目标日期: " & targetDate, vbExclamation
        End If
    End With
    
    kpiWB.Save
    kpiWB.Close SaveChanges:=False

Cleanup:
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    If Err.Number <> 0 Then
        MsgBox "运行错误: " & Err.Description, vbCritical
    End If
    Workbooks("InitialWorkbook.xlsm").RefreshAll
End Sub

• 修正变量名拼写，确保Find方法使用已定义的日期变量
• 简化日期读取逻辑，直接从单元格获取日期值，避免依赖显示格式
• 优化Find参数，指定精准匹配规则，避免误匹配
• 用直接赋值替代复制粘贴，提升效率并避免剪贴板冲突
• 添加错误处理和状态恢复，确保宏运行后Excel回到正常状态

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