Vba exclude 2 shapes from selection by name

Question

I am trying to copy a range of cells which contains data and shapes, from sheet 1 to all other sheets in a workbook. However 2 shapes need to be excluded from the selection by name, other shapes need to be included.

I have already tried setting the shapes by name, to visible = False prior to copying, but they are still copied across.

I have also tried including them in the pasted data and then setting them to visible=false or deleting them from all other sheets. However the naming of the shapes are not consistent once pasted. Sometimes they are the same, sometimes they increment to the next available.

It seems to me the best method would be to subtract the specific shape range from the cell range prior to copy, however I cannot get it work.

There is no error, but all the shapes, including the 2 that need to be excluded are still copied across.

Here is what I have tried. How could I fix this?

    Dim TopRow As Range
    Dim arShapes() As Variant
    Dim ws As Worksheet
    Dim cellRange As Range
    Dim shapeRange As Range
    Dim resultRange As Range
    Dim shp As Shape
    Dim cell As Range
    
    ' Define the worksheet and cell range
    Set ws = Worksheets("Sheet1")
    Set TopRow = ws.Range("1:1")
    ' Set TopRow = Worksheets("Sheet1").Range("1:1")
    
    ' Define the shapes to subtract
    arShapes = Array("Button 1", "Oval 7")
    
    ' Set the cell range to be the entire top row
    Set cellRange = TopRow
    
    ' Initialize the resultRange with the cellRange
    Set resultRange = ws.Range(cellRange.Address)

    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Sheet1" Then
                       
            For Each shp In ws.Shapes
                If IsInArray(shp.Name, arShapes) Then
                    ' Check if the shape intersects with the resultRange
                    If Not Intersect(shp.TopLeftCell, resultRange) Is Nothing Then
                        ' Subtract the shape's range from the resultRange
                        Set resultRange = Application.Union(resultRange, shp.TopLeftCell)
                    End If
                End If
            Next shp
            
            resultRange.Copy
            
            ws.Range(cellRange.Address).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            ws.Paste
        End If
    Next ws

Answer 1

Logic:

1. Create an array to store the shape's (to be excluded) name and it's width and height details.
2. Set the width and height of the shape (to be excluded) to 0 before copying.
3. Copy the range and paste.
4. Reset the shape's width and height (In the main range) back to what it was.
5. Loop through all the shapes and delete the shapes whose width and height is 0 which do not fall under the copied range. I can omit the Intersect step but I have kept it for testing. I can simply delete all shapes with width and height as 0

Is this what you are trying?

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    '~~> Set this to the relevant sheet
    Set ws = Sheet1
    
    '~~> This array will store the details of the shapes
    '~~> That you would like to exclude
    Dim ArShapes() As String
    Dim CountOfShapesToBeExculded As Long
    CountOfShapesToBeExculded = 2
    ReDim ArShapes(1 To CountOfShapesToBeExculded, 1 To 3)
        
    '~~> Let's say we want to exclude these two shapes
    '~~> Get their details in the array
    ArShapes(1, 1) = "Oval 1"                   '<~~ Name of the shape
    ArShapes(1, 2) = ws.Shapes("Oval 1").Width     '<~~ Width
    ArShapes(1, 3) = ws.Shapes("Oval 1").Height    '<~~ Height
    
    ArShapes(2, 1) = "Teardrop 4"
    ArShapes(2, 2) = ws.Shapes("Teardrop 4").Width
    ArShapes(2, 3) = ws.Shapes("Teardrop 4").Height
    
    Dim i As Long
    
    '~~> Before copying, set the width and height to 0
    For i = LBound(ArShapes) To UBound(ArShapes)
        With ws.Shapes(ArShapes(i, 1))
            .Width = 0
            .Height = 0
        End With
    Next i
    
    'Debug.Print ws.Shapes.Count
    
    '~~> Perform the copy and paste
    Dim rng As Range
    Set rng = ws.Range("A1:H16")
    rng.Copy ws.Range("M1")
    
    '~~> Set the width and height back to normal
    For i = LBound(ArShapes) To UBound(ArShapes)
        With ws.Shapes(ArShapes(i, 1))
            .Width = ArShapes(i, 2)
            .Height = ArShapes(i, 3)
        End With
    Next i
    
    'Debug.Print ws.Shapes.Count

    Dim shp As Shape
    
    '~~> Delete the shape whose width and height is 0 which are not a
    '~~> part of the copied range
    For Each shp In ws.Shapes
        If Intersect(ws.Range(shp.TopLeftCell.Address), rng) Is Nothing Then
            If shp.Width = 0 Then shp.Delete
        End If
    Next shp
    
    'Debug.Print ws.Shapes.Count
End Sub

Output