Delete Shapes Above a Certain Row

[MikeG]

Could someone give me VBA code that I can attach to a button that will delete all the shapes in a specified worksheet that are located above a given row?

For example, the button is located in Sheet1, and Cell A10 of Sheet1 contains the text value "Sheet2" (although without the quotation marks". What I would like is that when I press the button, it would delete all the shapes in Sheet2 that are located above row 15. If Cell A10 of Sheet1 contained the text Sheet4, then I would like the macro to delete the shapes in Sheet4, and so on.

Thanks,

Mike

 

[Alex Blakenburg]

The below code should do what you want. Make sure you have a backup copy of your sheet before you run it.
I have commented it out the line for the TopLeftCell being above row 15 in favour of the BottomRIghtCell being above row 15 but both lines are there so just comment and uncomment per your requirement.

Sub DeleteShapesOnSht()

    Dim shp As Shape
    Dim controlSht As Worksheet
    Dim shapeSht As Worksheet
    
    Set controlSht = ActiveSheet
    Set shapeSht = Worksheets(controlSht.Range("A10").Value)
    
    For Each shp In shapeSht.Shapes
        'If shp.TopLeftCell.Row < 15 Then           ' Shape starts above nominated row no
        If shp.BottomRightCell.Row < 15 Then        ' Whole shape is above nominated row no
            shp.Delete
        End If
    
    Next shp
    
End Sub

If you wanted to have a look at the shapes to get a feel for what is going on and know how to look at the VBA Immediate window, the below will print to the immediate windon and does not delete anything.

Sub ListShapesOnSht()

    Dim shp As Shape
    Dim controlSht As Worksheet
    Dim shapeSht As Worksheet
    
    Set controlSht = ActiveSheet
    Set shapeSht = Worksheets(controlSht.Range("A10").Value)
    
    Debug.Print "Name", "Type No", "Top Left", "Bottom Right"
    Debug.Print "-----------------------------------------------------------------"
    
    For Each shp In shapeSht.Shapes
        Debug.Print shp.Name, shp.Type, shp.TopLeftCell.Row, shp.BottomRightCell.Row
    Next shp
    
End Sub

 

[MikeG]

The below code should do what you want. Make sure you have a backup copy of your sheet before you run it.
I have commented it out the line for the TopLeftCell being above row 15 in favour of the BottomRIghtCell being above row 15 but both lines are there so just comment and uncomment per your requirement.

Sub DeleteShapesOnSht()

    Dim shp As Shape
    Dim controlSht As Worksheet
    Dim shapeSht As Worksheet
   
    Set controlSht = ActiveSheet
    Set shapeSht = Worksheets(controlSht.Range("A10").Value)
   
    For Each shp In shapeSht.Shapes
        'If shp.TopLeftCell.Row < 15 Then           ' Shape starts above nominated row no
        If shp.BottomRightCell.Row < 15 Then        ' Whole shape is above nominated row no
            shp.Delete
        End If
   
    Next shp
   
End Sub

If you wanted to have a look at the shapes to get a feel for what is going on and know how to look at the VBA Immediate window, the below will print to the immediate windon and does not delete anything.

Sub ListShapesOnSht()

    Dim shp As Shape
    Dim controlSht As Worksheet
    Dim shapeSht As Worksheet
   
    Set controlSht = ActiveSheet
    Set shapeSht = Worksheets(controlSht.Range("A10").Value)
   
    Debug.Print "Name", "Type No", "Top Left", "Bottom Right"
    Debug.Print "-----------------------------------------------------------------"
   
    For Each shp In shapeSht.Shapes
        Debug.Print shp.Name, shp.Type, shp.TopLeftCell.Row, shp.BottomRightCell.Row
    Next shp
   
End Sub

Thanks - that's great. And it is a powerful macro, so I appreciate the backup advice and the ability to see what's occurring.

 

[Alex Blakenburg]

Glad I could help & thanks for the feedback.