Issue with looping specific shape through all worksheets

I am trying to loop a picture/logo which I want to go into each sheet, which contains a rectangle in the top left corner.

Logo successfully fills into the rectangle, however I want to check each sheet if (Rectangle A") is present and then paste the shape which contains the image

I have made an error with the loop where it gets stuck in an infinite loop and pastes it in the same sheet

Can I kindly get some assistance, please

    Dim myshape As Shape
    Set myshape = ActiveSheet.Shapes("Rectangle A")
    
    myshape.Copy
    
            For Each ws In ActiveWorkbook.Worksheets
               
                    If ws.Shapes.Count > 0 Then
    
                        ActiveSheet.Shapes("Rectangle A").Select            
    
                    For Each myshape In ws.Shapes
                  
                       ActiveSheet.Paste
          
                       Next myshape
    
    End If
    Next ws

If I understand that what you want to do is:

"Make sure every sheet has a copy of Rectangle A, if not, paste it up the top left"

...then the below should help.

Sub TestShapes()
  
  Dim Ws As Worksheet, MyShape As Shape
  
  ActiveSheet.Shapes("Rectangle A").Copy

  For Each Ws In ActiveWorkbook.Worksheets
  
    'Check if "Rectangle A" exists
    On Error Resume Next
    Set MyShape = Nothing
    Set MyShape = Ws.Shapes("Rectangle A")
    Err.Clear
    On Error GoTo 0
    
    If MyShape Is Nothing Then
      Ws.Paste Ws.Range("A1")
    End If
    
  Next Ws

End Sub

The reason you ended up in an infinite loop is because in this part...

For Each myshape In ws.Shapes

    ActiveSheet.Paste

Next myshape

...you were iterating through every shape on the "ws" sheet, but you were adding to the "activesheet", instead of "ws". This meant that when ws = activesheet, you were iterating through the list of shapes on the activehseet AND adding more shapes to iterate through, hence the infinite loop.

If you were looking for "Make sure every sheet that has Rectangle A up the top left gets my copied Rectangle A up the top left" then the below will help:

Sub TestShapes()
  
  Dim Ws As Worksheet, MyShape As Shape
  
  ActiveSheet.Shapes("Rectangle A").Copy

  For Each Ws In ActiveWorkbook.Worksheets
  
    'Check if "Rectangle A" exists
    On Error Resume Next
    Set MyShape = Nothing
    Set MyShape = Ws.Shapes("Rectangle A")
    Err.Clear
    On Error GoTo 0
    
    If not MyShape Is Nothing Then
      Ws.Paste Ws.Range("A1")
    End If
    
  Next Ws

End Sub