[VBA] Delete shapes with values

GroupThink

New Member
Joined
Nov 27, 2018
Messages
5
I have about 20 sheets, each with about 400 shapes (rounded rectangles). These shape values (ex. "=A32", "=B12", "=E24") are referencing 8 columns and 50 rows in the sheet. These referenced cells are using INDIRECT to pull data from another sheet, which is using IFERROR(INDEX..., so there is always a formula in the referenced cell.

Sometimes every cell on a page has data in it, other times it has little, depending on previous criteria.

The user moves/rearranges the shapes.

The issue is that when sheets end up having a lot of "blank" shapes, the user either has to move or delete them.

Is there a macro that looks at current sheet, sees if shape value is not blank, and deletes shape?
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
5,997
Welcome to MrExcel. I'm not quite sure what you mean by 'shape values' - do you mean the formula shown in the formula bar when you select one of the shapes? If so, try this macro on a copy of your workbook or sheet.

Code:
Public Sub Delete_Rectangle_Shapes_Active_Sheet()
    
    Dim shp As Shape
    
    For Each shp In ActiveSheet.Shapes
        If shp.AutoShapeType = msoShapeRoundedRectangle Then
            If shp.DrawingObject.Formula <> vbNullString Then 'the Shape's formula is not blank
                shp.Delete
            End If
        End If
    Next

End Sub
 

GroupThink

New Member
Joined
Nov 27, 2018
Messages
5
Welcome to MrExcel. I'm not quite sure what you mean by 'shape values' - do you mean the formula shown in the formula bar when you select one of the shapes? If so, try this macro on a copy of your workbook or sheet.

Code:
Public Sub Delete_Rectangle_Shapes_Active_Sheet()
    
    Dim shp As Shape
    
    For Each shp In ActiveSheet.Shapes
        If shp.AutoShapeType = msoShapeRoundedRectangle Then
            If shp.DrawingObject.Formula <> vbNullString Then [B]'the Shape's formula is not blank[/B]
                shp.Delete
            End If
        End If
    Next

End Sub
Thanks.

I believe so, if I am understanding what you are saying.

The shapes will always have a formula ("=AB34", etc.). The referenced cell for the shapes will always have a formula ("IFERROR(INDEX..."), but it may not be returning anything; it's removing blanks from a list. It's the ones that returned nothing I'd like to delete.

Just to be sure, I am including the bolded area (above, in quote) you had in it?
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
5,997
I think I understand you now. You want to delete shapes where the result of the shape's formula is blank.

Try this macro:

Code:
Public Sub Delete_Rectangle_Shapes_Active_Sheet_Formula_Result_Blank()
        
    Dim shp As Shape
    
    'Delete shapes on the active sheet if the result of its formula is blank

    For Each shp In ActiveSheet.Shapes
        If shp.AutoShapeType = msoShapeRoundedRectangle Then
            If shp.DrawingObject.Formula <> vbNullString Then
                If Evaluate(shp.DrawingObject.Formula) = "" Then        'result of the formula is blank
                    If MsgBox("Shape name: " & shp.Name & vbCrLf & _
                              "At cell:    " & shp.TopLeftCell.Address & vbCrLf & _
                              "Formula:    " & shp.DrawingObject.Formula & vbCrLf & _
                              "Result:     " & Evaluate(shp.DrawingObject.Formula) & vbCrLf & vbCrLf & _
                              "Delete this shape?", vbYesNo) = vbYes Then
                        shp.Delete
                    End If
                End If
            End If
        End If
    Next

End Sub
The If MsgBox and corresponding End If is an extra statement allowing you to confirm deletion of the shape and can be deleted if not needed.
 

GroupThink

New Member
Joined
Nov 27, 2018
Messages
5
I think I understand you now. You want to delete shapes where the result of the shape's formula is blank.

Try this macro:

Code:
Public Sub Delete_Rectangle_Shapes_Active_Sheet_Formula_Result_Blank()
        
    Dim shp As Shape
    
    'Delete shapes on the active sheet if the result of its formula is blank

    For Each shp In ActiveSheet.Shapes
        If shp.AutoShapeType = msoShapeRoundedRectangle Then
            If shp.DrawingObject.Formula <> vbNullString Then
                If Evaluate(shp.DrawingObject.Formula) = "" Then        'result of the formula is blank
                    If MsgBox("Shape name: " & shp.Name & vbCrLf & _
                              "At cell:    " & shp.TopLeftCell.Address & vbCrLf & _
                              "Formula:    " & shp.DrawingObject.Formula & vbCrLf & _
                              "Result:     " & Evaluate(shp.DrawingObject.Formula) & vbCrLf & vbCrLf & _
                              "Delete this shape?", vbYesNo) = vbYes Then
                        shp.Delete
                    End If
                End If
            End If
        End If
    Next

End Sub
The If MsgBox and corresponding End If is an extra statement allowing you to confirm deletion of the shape and can be deleted if not needed.
That worked perfectly!!!

So, if I want a message box to confirm deleting all or nothing (and not for each) what would I change?

There's hundreds per page.
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
5,997
Just put a message box prompt outside the loop:
Code:
Public Sub Delete_Rectangle_Shapes_Active_Sheet_Formula_Result_Blank2()
        
    Dim shp As Shape
    
    If MsgBox("Do you want to delete ALL Rounded Rectangle shapes on the active sheet, " & ActiveSheet.Name & ", whose formula result is blank?", vbYesNo) = vbNo Then
        Exit Sub
    End If
    
    'Delete shapes on the active sheet if the result of its formula is blank
    
    For Each shp In ActiveSheet.Shapes
        If shp.AutoShapeType = msoShapeRoundedRectangle Then
            If shp.DrawingObject.Formula <> vbNullString Then
                If Evaluate(shp.DrawingObject.Formula) = "" Then        'result of the formula is blank
                    shp.Delete
                End If
            End If
        End If
    Next

End Sub
 

GroupThink

New Member
Joined
Nov 27, 2018
Messages
5
Thanks. It worked perfectly.

Unfortunately something just came up. What can I do to make it skip Rounded Rectangle 266 through 281?
 

GroupThink

New Member
Joined
Nov 27, 2018
Messages
5
Figured it out.

Had to add the names, individually, but it works.

Thanks for the help John_w!
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
5,997
Unfortunately something just came up. What can I do to make it skip Rounded Rectangle 266 through 281?
Try this:
Code:
Public Sub Delete_Rectangle_Shapes_Active_Sheet_Formula_Result_Blank2a()
        
    Dim shp As Shape, p As Long
    
    If MsgBox("Do you want to delete ALL Rounded Rectangle shapes on the active sheet, " & ActiveSheet.Name & ", whose formula result is blank, except numbers 266 to 281?", vbYesNo) = vbNo Then
        Exit Sub
    End If
    
    'Delete shapes on the active sheet if the result of its formula is blank
    
    For Each shp In ActiveSheet.Shapes
        If shp.AutoShapeType = msoShapeRoundedRectangle Then
            p = InStrRev(shp.Name, " ")
            If CLng(Mid(shp.Name, p + 1)) < 266 Or CLng(Mid(shp.Name, p + 1)) > 281 Then
                If shp.DrawingObject.Formula <> vbNullString Then
                    If Evaluate(shp.DrawingObject.Formula) = "" Then        'result of the formula is blank
                        shp.Delete
                    End If
                End If
            End If
        End If
    Next

End Sub
 

Forum statistics

Threads
1,081,795
Messages
5,361,333
Members
400,627
Latest member
Mcomeaux

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top