粘贴图表至工作表时偶发“Method 'Paste' of object '_Worksheet' failed”错误

从其他工作表粘贴图表图片时，偶尔触发错误：

Method 'Paste' of object '_Worksheet' failed

触发错误的VBA代码如下：

Dim ViewerWS As Worksheet, myWS As Worksheet
Set ViewerWS = Sheets("Viewer")
Dim InCopy As Long, InPaste As Long
On Error GoTo ErrorHandler
Dim count As Long
For Each myWS In Sheets
    If Mid(myWS.Name, 1, 1) = "6" And Len(myWS.Name) = 10 Then
    On Error GoTo ErrorHandler
    ' Erreur "Method 'Paste' of object '_Worksheet' failed"
GoInCopy:
            On Error GoTo ErrorHandler
            InCopy = InCopy + 1
            DoEvents
            myWS.ChartObjects("main").CopyPicture
            InCopy = 0
            
GoInPaste:
            On Error GoTo ErrorHandler
            InPaste = InPaste + 1
            DoEvents
            ViewerWS.Paste
            InPaste = 0
Next
Exit Sub
ErrorHandler:
    Debug.Print "Error caught : " & Err.Description & " / " & InCopy & " / " & InPaste
    If InCopy > 0 And InCopy < 10 Then GoTo GoInCopy
    If InPaste > 0 And InPaste < 10 Then GoTo GoInPaste
    Resume Next

错误发生在ViewerWS.Paste行，控制台输出：

Error caught : Method 'Paste' of object '_Worksheet' failed / 0 / 1

试过写错误重试逻辑但没用，进调试模式按F5却每次都能正常执行。

问题根源 #

这类偶发错误本质是剪贴板还没写完图表数据，VBA就急着执行粘贴。调试模式下代码会停顿，剪贴板有足够时间同步数据，所以不会报错。原重试逻辑的问题在于：触发错误时InPaste被设为1，但跳转重试时没重置错误状态，也没给剪贴板留够等待时间，等于白重试。

修复方案 #

1. 优化代码逻辑，增加剪贴板等待 #

直接上修改后的代码，关键是加了剪贴板检查和重试间隔：

Dim ViewerWS As Worksheet, myWS As Worksheet
Set ViewerWS = Sheets("Viewer")
Dim retryCount As Integer
Dim waitTime As Integer

' 临时关闭自动计算和屏幕更新，减少线程冲突
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

For Each myWS In Sheets
    If Mid(myWS.Name, 1, 1) = "6" And Len(myWS.Name) = 10 Then
        retryCount = 0
        ' 最多重试10次
        Do While retryCount < 10
            On Error Resume Next
            ' 明确复制参数，避免格式歧义
            myWS.ChartObjects("main").CopyPicture xlScreen, xlPicture
            If Err.Number = 0 Then
                ' 等剪贴板准备好图片，最多等2秒
                waitTime = 0
                Do While Not ClipboardHasPicture() And waitTime < 20
                    DoEvents
                    Application.Wait Now + TimeValue("00:00:00.1")
                    waitTime = waitTime + 1
                Loop
                ' 指定位置粘贴，避免焦点问题
                ViewerWS.Range("A1").PasteSpecial
                If Err.Number = 0 Then
                    Exit Do ' 成功就跳出重试循环
                End If
            End If
            On Error GoTo 0
            retryCount = retryCount + 1
            DoEvents
            Application.Wait Now + TimeValue("00:00:00.5") ' 重试间隔0.5秒
        Loop
        If retryCount >= 10 Then
            Debug.Print "失败：" & myWS.Name & "的main图表复制粘贴失败"
        End If
    End If
Next

' 恢复Excel默认设置
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Exit Sub

' 辅助函数：检查剪贴板是否有图片
Function ClipboardHasPicture() As Boolean
    Dim obj As Object
    Set obj = CreateObject("htmlfile")
    ClipboardHasPicture = obj.Parent.ClipboardData.GetData("Picture") Is Not Nothing
    Set obj = Nothing
End Function

关键修改点 #

• 用Do While替代原有的GoTo跳转，逻辑更清晰
• 加了ClipboardHasPicture函数，确认剪贴板有图片再粘贴
• 复制时明确xlScreen和xlPicture参数，避免复制格式混乱
• 粘贴用PasteSpecial并指定位置，减少因工作表焦点导致的失败
• 临时关闭自动计算和屏幕更新，降低Excel线程冲突概率
• 每次重试加0.5秒间隔，给系统足够时间处理剪贴板

额外小技巧 #

如果还是偶尔出错，可以在复制前加一行ViewerWS.Activate，确保目标工作表处于激活状态，减少焦点问题。

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