为什么在使用 Excel 宏复制粘贴形状时会出现自动化错误，但如果我放慢代码速度则不会？

Question

当我尝试根据单元格的值将一些现有形状复制粘贴到单元格中时，我的宏将在复制几次（少于 10 个）后失败并出现以下错误：

Run-time error '-2147221040 (800401d0)': Automation error OpenClipboard Failed

我最初认为这可能是某种剪贴板缓冲区问题，所以我在每次粘贴后添加了这个命令：

Application.CutCopyMode = False

但它并没有改变任何东西。

但后来我注意到，如果在我的代码上放置一些断点运行它 "step-by-step" （在断点处按 F5），它工作正常...只要我不这样做按 F5 太快了。

最后我在每次粘贴后添加了 1s 的等待，这样代码运行s 没有任何错误直到最后（但对于几千次粘贴来说非常慢）。

下面我目前的代码运行:

Sub Change_to_icon()
Dim cell As Range

For Each cell In ActiveSheet.Range("C4:AI28")
    If cell.Value = "" Then
        cell.Value = "0"
    ElseIf cell.Value = "1" Then
        ActiveSheet.Shapes("CD").Copy
        cell.Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Application.Wait (Now + TimeValue("0:00:01"))
    ElseIf cell.Value = "2" Then
        ActiveSheet.Shapes("CDW").Copy
        cell.Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Application.Wait (Now + TimeValue("0:00:01"))
    ElseIf cell.Value = "3" Then
        ActiveSheet.Shapes("E").Copy
        cell.Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Application.Wait (Now + TimeValue("0:00:01"))
    ElseIf cell.Value = "4" Then
        ActiveSheet.Shapes("CT").Copy
        cell.Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Application.Wait (Now + TimeValue("0:00:01"))
    End If


Next cell

End Sub

在其他一些主题中，有人在一些非常相似的情况下提出建议，而不是循环中可能存在差异，例如尝试在复制之前粘贴（我觉得很好理解），并添加一些 DoEvents。我也在代码的不同地方试过这个。没有改变任何东西。

此外，所有粘贴的新形状都有相似的名称，我可以想象它在某处有一些意想不到的副作用，但我没有尝试为每个粘贴都给它们一个新名称。

当它运行没有等待的情况下全速运行时，您认为会发生什么？

Answer 1

您可以使用 Shape.Duplicate 而不是复制粘贴。以下代码在我的电脑上用了不到2s复制了1000多个形状：

With ActiveSheet

    Dim cell As Range
        For Each cell In .Range("C4:AI28")

        Dim shapeName As String
        shapeName = ""

        Select Case cell.Value
            Case 0: cell.Value = 1
            Case 1: shapeName = "CD"
            Case 2: shapeName = "CDW"
            (...)
        End Select

        If shapeName <> "" Then
            Dim shCopy As Shape
            Set shCopy = .Shapes(shapeName).Duplicate
            shCopy.Left = cell.Left
            shCopy.Top = cell.Top
            shCopy.Name = shapeName & "_" & cell.Address(False, False)
        End If
    Next cell
End With

Answer 2

我有这个不方便，看起来剪贴板在尝试复制和粘贴时卡住了，玩了一会儿后发现了一些对我有帮助的东西。

首先设置一个函数来设置延迟时间

 If VBA7 Then    
      Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 #Else

 Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

 #End If

 Sub prcWaiting(ByVal Mili_Seconds&)
     Sleep Mili_Seconds
 End Sub

我创建了一个专门执行复制的函数，并设置和错误处理程序以了解是否复制了副本，如果复制成功则为真，否则会出现错误 false

 Private Function funCopyMinusButton() As Boolean
     On Error GoTo ErrHandler
     Sheets("_Resources").Shapes("btnMinus").Copy

     funCopyMinusButton = True
 Done:
     Exit Function

 ErrHandler:
     funCopyMinusButton = False
 End Function

如果函数 returns false 我给了 2 秒的时间让 Excel 释放剪贴板然后重试复制，有时可能会循环几秒钟，然后继续复制粘贴过程
```
 errTry:

 If Not funCopyMinusButton Then
     prcWaiting 2000
     GoTo errTry
 End If
```

我希望这对其他有同样错误的人有用。

为什么在使用 Excel 宏复制粘贴形状时会出现自动化错误，但如果我放慢代码速度则不会？

Why do I get an Automation Error when copy-pasting shapes with an Excel macro, but not if I slow down the code?

excel

vba

runtime-error

copy-paste