[VBA] Delete shapes with values

[GroupThink]

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]

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.

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]

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.

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]

I think I understand you now. You want to delete shapes where the result of the shape's formula is blank.

Try this macro:

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]

I think I understand you now. You want to delete shapes where the result of the shape's formula is blank.

Try this macro:

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]

Just put a message box prompt outside the loop:

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]

Thanks. It worked perfectly.

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

 

[GroupThink]

Figured it out.

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

Thanks for the help John_w!

 

[John_w]

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

Try this:

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