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

Question

When I try to copy-paste some existing shapes into cells depending on the value of the cells, my macro will fail after few copies (less than 10) with the following error:

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

I initially thought that might be some kind of Clipboard buffer issue so I added this command after each paste:

Application.CutCopyMode = False

But it didn't change anything.

But then I noticed that if put some breakpoint on my code and run it "step-by-step" (F5 when at the breakpoint), it works fine... as long as I don't press F5 too quickly.

In the end I added a wait of 1s after each Paste, and this way the code runs without any error till the end (but crazy slow for a few thousands paste).

Below the code I currently run:

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

In some other topics someone was suggesting in some rather similar situation than there may be a discrepancy in the loop like trying to paste before copy (I fI understood well), and to add some DoEvents. I also tried this at different places in the code. Didn't change anything.

Also, all the new shapes pasted have similar names, I could imagine that it has some unexpected side effect somewhere but I didn't try to give them a new name for each Paste.

What do you think is happening when it's running full speed without the Wait?

Answer 1

Instead of Copy&Paste, you can use Shape.Duplicate. The following code took less than 2s to copy more than 1000 shapes on my computer:

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