1004 error when copying and pasting shapes via VBA in Excel

Question

When I try and copy and paste shapes in Excel, I get a debug message telling me there is a

1004 error - Copy Method of Picture Class Failed

When I then press continue in the macro, it works? I tried adding an Application.Wait(5) statement to add a delay in, but the same thing happens. I tried adding DoEvents between the Copy and Paste , but it didn't help.

Public Sub PlotApprovals()
    Dim lngRow As Long
    Dim lngCol As Long
    Dim strCountry As String
    Dim datEmergencyUseApproval As Date
    Dim rngSyringe As Range
    Dim intCountryCols As Integer
    Dim intColCount As Integer
    Dim shpCopy As Shape
    Dim shpPaste As Shape
    Dim intShapeIndex As Integer
    
    intCountryCols = 1
    intColCount = 4
    
    lngCol = 4
    
    DeleteShapes
    
    For intColCount = 1 To 4
        If intColCount = 1 Then
            lngCol = 4
        ElseIf intColCount = 2 Then
             lngCol = 9
        ElseIf intColCount = 2 Then
         lngCol = 14
        ElseIf intColCount = 2 Then
         lngCol = 19
        End If
        
        For lngRow = 3 To 42
            Set rngSyringe = shtDashboard.Cells(lngRow, lngCol + 1)
            strCountry = shtDashboard.Cells(lngRow, lngCol)
            datEmergencyUseApproval = Application.WorksheetFunction.VLookup(strCountry, shtData.Range("A:X"), 24, False)
            If datEmergencyUseApproval <> 0 Then
                Set shpCopy = shtDashboard.Shapes("syringeEmergencyUse")
                shpCopy.Copy
                shtDashboard.Paste
                intShapeIndex = idxLastShape("Dashboard")
                Set shpCopy = shtDashboard.Shapes(intShapeIndex)
                shpCopy.Name = "syringe"
                shpCopy.Left = rngSyringe.Left
                shpCopy.Top = rngSyringe.Top
            End If
        Next lngRow
    Next intColCount
End Sub




Public Sub DeleteShapes()

    Dim shp As Shape
    
    For Each shp In ActiveSheet.Shapes
        If shp.Name = "syringe" Then
            shp.Delete
        End If
    Next shp
End Sub


Function idxLastShape(shtName As String) As Long
    Dim sh As Shape
    For Each sh In Sheets(shtName).Shapes
        idxLastShape = idxLastShape + 1
    Next sh
End Function

----------UPDATE-------------

If the main copy and paste logic is updated as below, I now get a Copy of Object Shape failed error. It takes me into Debug, where if I proceed it works. So the failure is at runtime, but it works in debug mode when I step through.

Set shpCopy = shtDashboard.Shapes("syringeEmergencyUse")
shpCopy.Select
shpCopy.Copy
rngSyringe.Select
shtDashboard.Paste
intShapeIndex = idxLastShape("Dashboard")
Set shpCopy = shtDashboard.Shapes(intShapeIndex)
shpCopy.Name = "syringe"
shpCopy.Left = rngSyringe.Left
shpCopy.Top = rngSyringe.Top
GreenCell rngCountry

Answer 1

The issue appears when you shtDashboard.Paste and there is a shape selected and not a cell. Make sure you select a cell before pasting:

shpCopy.Select
shpCopy.Copy
shtDashboard.Range("A1").Select 'select a cell to ensure no shape is selected
shtDashboard.Paste

Answer 2

The solution it seems is to add this after the copy, must be a timing issue:

shp.Copy
Application.Wait(Now+TimeSerial(0,0,2))
DoEvents
rngSyringe.Select
ActiveSheet.Paste