Copy paste crashing when run but working if stepped through

Question

The following code copies and pastes pictures from the worksheet 'RefData' to another worksheet called 'Dashboard' based on a value in a column H/L on the 'Dashboard' worksheet.

It had been working for a couple of years but recently, it runs but then immediately throws me out of Excel. If I step through it works.

Public Sub UpdatePictures()    
    Dim IconRefresh As Variant  

    Sheets("Dashboard").Select
    If ActiveSheet.Pictures.Count > 1 Then
        ActiveSheet.Shapes.SelectAll
        Selection.Delete
        MsgBox "Pictures Deleted"
    Else
        MsgBox "No Pictures To Delete"
    End If

    Sheets("RefData").Select
    ActiveSheet.Shapes.Range(Array("Common")).Select
    Selection.Copy
    Sheets("Dashboard").Select
    For Each Cell In Range("H6:H15")
        If Cell.Value = "Common" Then
            Cell.Offset(0, 20).Select
            ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 15
            Selection.ShapeRange.IncrementTop 3.5
        End If
    Next

    Sheets("RefData").Select
    ActiveSheet.Shapes.Range(Array("HighSpecial(Concern)")).Select
    Selection.Copy
    Sheets("Dashboard").Select
    For Each Cell In Range("H6:H15")
        If Cell.Value = "HighSpecial(Concern)" Then
            Cell.Offset(0, 20).Select
            ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 15
            Selection.ShapeRange.IncrementTop 3.5
        End If
    Next

    Sheets("RefData").Select
    ActiveSheet.Shapes.Range(Array("Pass")).Select
    Selection.Copy
    Sheets("Dashboard").Select
    For Each Cell In Range("L6:L15")
        If Cell.Value = "Pass" Then
            Cell.Offset(0, 19).Select
            ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 15
            Selection.ShapeRange.IncrementTop 3.5
        End If
    Next

    Sheets("RefData").Select
    ActiveSheet.Shapes.Range(Array("Fail")).Select
    Selection.Copy
    Sheets("Dashboard").Select
    For Each Cell In Range("L6:L15")
        If Cell.Value = "Fail" Then
            Cell.Offset(0, 19).Select
            ActiveSheet.Paste
            Selection.ShapeRange.IncrementLeft 15
            Selection.ShapeRange.IncrementTop 3.5
        End If
    Next

    Sheets("RefData").Select
    Sheets("Dashboard").Select
    Range("AA5").Select
    
    MsgBox "Pictures Updated"
End Sub

Answer 1

I have definitely noticed that copy/paste in Excel has become pretty flakey in the past few years, particularly when in a loop and pictures/shapes are involved.

Try this out - a little refactored, and using a separate sub to perform the copy/paste, with re-tries if it fails:

Option Explicit

Public Sub UpdatePictures()
    Dim wsDash As Worksheet, wsRef As Worksheet
    Dim c As Range, v, shp As Shape
    
    'use worksheet variables...
    Set wsDash = ThisWorkbook.Worksheets("Dashboard")
    Set wsRef = ThisWorkbook.Worksheets("RefData")

    'remove any existing shapes
    If wsDash.Pictures.Count > 1 Then
        wsDash.DrawingObjects.Delete
        MsgBox "Pictures Deleted"
    Else
        MsgBox "No Pictures To Delete"
    End If
    
    'only need to loop each range once...
    For Each c In wsDash.Range("H6:H15").Cells
        v = c.Value
        If v = "Common" Or v = "HighSpecial(Concern)" Then
            'call the Sub to perform the copy/paste...
            CopyPastePicRetry wsRef.Shapes(v), c.Offset(0, 20)
        End If
    Next c
    
    For Each c In wsDash.Range("L6:L15").Cells
        v = c.Value
        If v = "Pass" Or v = "Fail" Then
            CopyPastePicRetry wsRef.Shapes(v), c.Offset(0, 19)
        End If
    Next c
    
    'adjust all shape positions on Dashboard
    For Each shp In wsDash.Shapes
        shp.IncrementLeft 15
        shp.IncrementTop 3.5
    Next shp

    wsDash.Select
    wsDash.Range("AA5").Select
    MsgBox "Pictures Updated"
End Sub

'Try to copy/paste a shape: re-try if fails, up to 20 times
Sub CopyPastePicRetry(shpToCopy As Shape, rngPaste As Range)
    Dim i As Long
    i = 1
    Do While i < 20
        On Error Resume Next
        shpToCopy.Copy
        rngPaste.PasteSpecial
        If Err.Number <> 0 Then
            Debug.Print "Copy/Paste failed; try #", i
            DoEvents
            i = i + 1
        Else
            Exit Sub 'copy/paste completed successfully
        End If
        On Error GoTo 0
        i = i + 1
    Loop
    'if got to this point then copy/paste did not succeed
    MsgBox "Failed to copy shape '" & shpToCopy.Name & "' to " & rngPaste.Address
End Sub