Deleting all pictures / shapes in a range

toboggan · Jul 10, 2014

I've been searching and searching to find an answer for this and, while I've found many answers, none of them seem to be working for me. I'm trying to copy several rows and then paste them below. There is a specific area that will sometimes have pictures and/or shapes that I don't want to copy down to the newly created rows. So I'm trying to select the shapes within the newly created area and delete them.

Most of the code I've found so far seem to be some variation of this:

Code:

Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
            If Not Intersect(Range("B454:AA480"), sh.TopLeftCell) Is Nothing And _
               Not Intersect(Range("B454:AA480"), sh.BottomRightCell) Is Nothing Then
                sh.Delete
            End If
        Next sh

However, this code is giving me Run-time error '1004': Application-defined or object-defined error.

Weird thing is. I ran it once and it seemed to work, but if I delete the rows that were created and run the macro again, I continuously get the error above.

toboggan · Jul 11, 2014

I'll work on it, but in the meantime, here's a couple more fun facts. If I close out of Excel, it works. So, it'll work once and then it won't work again. However, if you close out of Excel and then try again, it'll work.

Also, I get the error even if there are no shapes in the area to delete.

toboggan · Jul 11, 2014

I tried the problem coding (just changed the range to be near the top of the sheet) on a new sheet and it has no problem completing the task over and over. I'm thinking there must be something in the rest of the code that is causing problems for this section of code.

Here is the code in its entirety:

Code:

Sub CreateType8()
Application.ScreenUpdating = False 'Turns Screen Updating off so macro can run faster
'Copy and Insert Type
    Rows("409:448").Select
    Selection.Copy
    Rows("450:450").Select
    Selection.Insert
    
    'This code finds the copied Return To Top and Add Type rectangles and changes their colors and assigns _
    a macro to the Add Type rectangle
    
    Dim shape_count, rect_count, num_rect As Integer
    
    
    shape_count = 0
    num_rect = 0
    'find last Return To Top rectangle
    For Each oShape In ActiveSheet.Shapes
        If oShape.Name = "Return To Top" Then
          rect_count = shape_count
          num_rect = num_rect + 1
        End If
        shape_count = shape_count + 1
    Next
    
           
    'change last Return To Top rectangle
    shape_count = 0
    For Each oShape In ActiveSheet.Shapes
         If shape_count = rect_count Then
           With oShape.Fill
             .Visible = msoTrue
             .ForeColor.ObjectThemeColor = msoThemeColorAccent6
             .ForeColor.TintAndShade = 0
             .ForeColor.Brightness = -0.5
             .Transparency = 0
             .Solid
          End With
          Exit For
        End If
        shape_count = shape_count + 1
    Next
    
    
    'Make the same changes to Add Type Rectangle
    
     shape_count = 0
    num_rect = 0
    'find last Add Type rectangle
    For Each oShape In ActiveSheet.Shapes
        If oShape.Name = "Add Type" Then
          rect_count = shape_count
          num_rect = num_rect + 1
        End If
        shape_count = shape_count + 1
    Next
    
           
    'change last Add Type rectangle
    shape_count = 0
    For Each oShape In ActiveSheet.Shapes
         If shape_count = rect_count Then
           With oShape.Fill
             .Visible = msoTrue
             .ForeColor.ObjectThemeColor = msoThemeColorAccent6
             .ForeColor.TintAndShade = 0
             .ForeColor.Brightness = -0.5
             .Transparency = 0
             .Solid
          End With
          Exit For
        End If
        shape_count = shape_count + 1
    Next
    
    
       
    'apply macro to Add Type rectangle
     shape_count = 0
    For Each oShape In ActiveSheet.Shapes
         If shape_count = rect_count And oShape.Name = "Add Type" Then
            With oShape
                .OnAction = "TimeToMakeTheMacros"
            End With
            Exit For
        End If
        shape_count = shape_count + 1
    Next
   
    
    
    'Code below changes background colors to distinguish between types'
            'Color Line Concept Section'
    Range("B453:AZ453").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    
            'Color Cost Estimate Section'
    Range("AD452:AZ453").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    
            'Color Skinny Strip between Cycle Time and Cost Table'
    Range("AD454:AD489").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
            
            'Color Weld Section'
    Range("B481:AD481").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    Range("B481:B489").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    Range("C481:D485").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    Range("E485:AD485").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    Range("V482:AD484").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    Range("AA486:AD489").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    Range("C489:Z489").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    Range("I486:U488").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    
            'Color Skinny Strip Right of Cost Table'
    Range("AZ454:AZ489").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    
            'Color Cycle Time Details
    Range("BQ451:HH451").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    
    
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
            If Not Intersect(Range("B454:AA480"), sh.TopLeftCell) Is Nothing And _
               Not Intersect(Range("B454:AA480"), sh.BottomRightCell) Is Nothing Then
                sh.Delete
            End If
        Next sh
    

    
    'Deleting any pre-existing cost data
    Range("AE456:AE478").Select
    Selection.ClearContents
    Range("AV456:AV478").Select
    Selection.ClearContents
    
    
    'Deleting any pre-existing cycle time data
    Range("BR453:BS468").Select
    Selection.ClearContents
    Range("BT454:BU468").Select
    Selection.ClearContents
    Range("CM453:CN468").Select
    Selection.ClearContents
    Range("CO454:CP468").Select
    Selection.ClearContents
    Range("DH453:DI468").Select
    Selection.ClearContents
    Range("DJ454:DK468").Select
    Selection.ClearContents
    Range("EC453:ED468").Select
    Selection.ClearContents
    Range("EE454:EF468").Select
    Selection.ClearContents
    Range("EX453:EY468").Select
    Selection.ClearContents
    Range("EZ454:FA468").Select
    Selection.ClearContents
    Range("FS453:FT468").Select
    Selection.ClearContents
    Range("FU454:FV468").Select
    Selection.ClearContents
    Range("GN453:GO468").Select
    Selection.ClearContents
    Range("GP454:GQ468").Select
    Selection.ClearContents
    Range("BR472:BS487").Select
    Selection.ClearContents
    Range("BT473:BU487").Select
    Selection.ClearContents
    Range("CM472:CN487").Select
    Selection.ClearContents
    Range("CO473:CP487").Select
    Selection.ClearContents
    Range("DH472:DI487").Select
    Selection.ClearContents
    Range("DJ473:DK487").Select
    Selection.ClearContents
    Range("EC472:ED487").Select
    Selection.ClearContents
    Range("EE473:EF487").Select
    Selection.ClearContents
    Range("EX472:EY487").Select
    Selection.ClearContents
    Range("EZ473:FA487").Select
    Selection.ClearContents
    Range("FS472:FT487").Select
    Selection.ClearContents
    Range("FU473:FV487").Select
    Selection.ClearContents
    Range("GN472:GO487").Select
    Selection.ClearContents
    Range("GP473:GQ487").Select
    Selection.ClearContents

    
    'The following code fixes the data validation problem that happens when the rows are copy and pasted
    Range("BR453,CM453,DH453,EC453,EX453,FS453,GN453,BR472,CM472,DH472,EC472,EX472,FS472,GN472") = "Associate"
            
            'First Row of Cycle Time Entry Boxes
    Range("BR454").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($BR$453,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("BR455:BR468").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("BR453") = ""
    
    Range("CM454").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($CM$453,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("CM455:CM468").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("CM453") = ""
    
    Range("DH454").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($DH$453,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("DH455:DH468").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("DH453") = ""
    
    Range("EC454").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($EC$453,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("EC455:EC468").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("EC453") = ""
    
    Range("EX454").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($EX$453,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("EX455:EX468").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("EX453") = ""
    
    Range("FS454").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($FS$453,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("FS455:FS468").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("FS453") = ""
    
    Range("GN454").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($GN$453,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("GN455:GN468").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("GN453") = ""
    
            'Second Row of Cycle Time Entry Boxes
    Range("BR473").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($BR$472,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("BR474:BR487").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("BR472") = ""
    
    Range("CM473").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($CM$472,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("CM474:CM487").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("CM472") = ""
    
    Range("DH473").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($DH$472,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("DH474:DH487").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("DH472") = ""
    
    Range("EC473").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($EC$472,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("EC474:EC487").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("EC472") = ""
    
    Range("EX473").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($EX$472,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("EX474:EX487").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("EX472") = ""
    
    Range("FS473").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($FS$472,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("FS474:FS487").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("FS472") = ""
    
    Range("GN473").Select
    Application.CutCopyMode = False
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(SUBSTITUTE($GN$472,"" "",""_""))"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With
    Selection.Copy
    Range("GN474:GN3487").Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("GN472") = ""
   
    
    
    'Comp Summary Sheet data goes down one row at a time so this must be done to get the right data _
    into these cells'
    Range("O450") = "='Comp Summary Sheet'!G13" 'Comp Information Type 7
    Range("AJ450") = "='Comp Summary Sheet'!P13" 'Revision Level Number
    Range("AL450") = "='Comp Summary Sheet'!Q13" 'Revision Level Date
    Range("AQ450") = "='Comp Summary Sheet'!S13" 'Comment
    Range("AX450") = "='Comp Summary Sheet'!W13" 'F REV
    
    'Puts Type Name into Line Process Box: this way we can keep it open for manual entry
    
    Range("AE80") = "=E451"
    
    'Brings viewing area to the top left portion of the type'
    Application.Goto Reference:="R449C1", Scroll:=True
    
    Application.ScreenUpdating = True 'Turns Screen Updating back on
    
End Sub

I'm thinking it has something to do with this section since shapes are involved:

Code:

    'This code finds the copied Return To Top and Add Type rectangles and changes their colors and assigns _
    a macro to the Add Type rectangle
    
    Dim shape_count, rect_count, num_rect As Integer
    
    
    shape_count = 0
    num_rect = 0
    'find last Return To Top rectangle
    For Each oShape In ActiveSheet.Shapes
        If oShape.Name = "Return To Top" Then
          rect_count = shape_count
          num_rect = num_rect + 1
        End If
        shape_count = shape_count + 1
    Next
    
           
    'change last Return To Top rectangle
    shape_count = 0
    For Each oShape In ActiveSheet.Shapes
         If shape_count = rect_count Then
           With oShape.Fill
             .Visible = msoTrue
             .ForeColor.ObjectThemeColor = msoThemeColorAccent6
             .ForeColor.TintAndShade = 0
             .ForeColor.Brightness = -0.5
             .Transparency = 0
             .Solid
          End With
          Exit For
        End If
        shape_count = shape_count + 1
    Next
    
    
    'Make the same changes to Add Type Rectangle
    
     shape_count = 0
    num_rect = 0
    'find last Add Type rectangle
    For Each oShape In ActiveSheet.Shapes
        If oShape.Name = "Add Type" Then
          rect_count = shape_count
          num_rect = num_rect + 1
        End If
        shape_count = shape_count + 1
    Next
    
           
    'change last Add Type rectangle
    shape_count = 0
    For Each oShape In ActiveSheet.Shapes
         If shape_count = rect_count Then
           With oShape.Fill
             .Visible = msoTrue
             .ForeColor.ObjectThemeColor = msoThemeColorAccent6
             .ForeColor.TintAndShade = 0
             .ForeColor.Brightness = -0.5
             .Transparency = 0
             .Solid
          End With
          Exit For
        End If
        shape_count = shape_count + 1
    Next

Andrew Poulsom · Jul 11, 2014

I can't possibly test all that code without a copy of your workbook, sorry.

toboggan · Jul 11, 2014

I understand. Do you think this:

Code:

For Each oShape In ActiveSheet.Shapes

might be clashing with this:

Code:

For Each sh In ActiveSheet.Shapes

?

I don't think i did a Dim oShape as anything...

toboggan · Jul 11, 2014

Scratch that... that didn't work either.

toboggan · Jul 14, 2014

Any reason that code would work without problems in one file, but in another file work once and then quit?

I've been searching for similar problems and came across this:

excel macro won't run twice - Access World Forums

The suggested solution is to use non-explicit references, however, being new to this, I don't have a good grasp of what that really means. Could this be an issue with my code?

Andrew Poulsom · Jul 14, 2014

I doubt that would apply in your case. It applies to Excel as an external application, not within Excel.

toboggan · Jul 14, 2014

Well given that it works perfectly fine with less than the full code in a different file, logic would dictate that there's some interaction happening between the code that's giving the error and some other piece of code within the macro right? So perhaps I should just add code in to the macro in the test file until I get the error? That's what I'll do and see if I can get anything to screw up that way.

toboggan · Jul 14, 2014

Ok, so I have been messing around with a test file and finally got it to put the same error out there. It seems to be due to some drop down lists I have with data validation. That seems to make the error happen. Any ideas as to why this would screw up the code?

I only have this as code for the new test file:

Code:

Sub Idiocy()
Application.ScreenUpdating = False 'Turns Screen Updating off so macro can run faster
'Copy and Insert Type
    Rows("6:16").Select
    Selection.Copy
    Rows("18:18").Select
    Selection.Insert
    
    'This code finds the copied Return To Top and Add Type rectangles and changes their colors and assigns _
    a macro to the Add Type rectangle
    
    Dim shape_count, rect_count, num_rect As Integer
    
    shape_count = 0
    num_rect = 0
    'find last Return To Top rectangle
    For Each oShape In ActiveSheet.Shapes
        If oShape.Name = "Return To Top" Then
          rect_count = shape_count
          num_rect = num_rect + 1
        End If
        shape_count = shape_count + 1
    Next
    
           
    'change last Return To Top rectangle
    shape_count = 0
    For Each oShape In ActiveSheet.Shapes
         If shape_count = rect_count Then
           With oShape.Fill
             .Visible = msoTrue
             .ForeColor.ObjectThemeColor = msoThemeColorAccent6
             .ForeColor.TintAndShade = 0
             .ForeColor.Brightness = -0.5
             .Transparency = 0
             .Solid
          End With
          Exit For
        End If
        shape_count = shape_count + 1
    Next
    
    
    'Make the same changes to Add Type Rectangle
    
     shape_count = 0
    num_rect = 0
    'find last Add Type rectangle
    For Each oShape In ActiveSheet.Shapes
        If oShape.Name = "Add Type" Then
          rect_count = shape_count
          num_rect = num_rect + 1
        End If
        shape_count = shape_count + 1
    Next
    
           
    'change last Add Type rectangle
    shape_count = 0
    For Each oShape In ActiveSheet.Shapes
         If shape_count = rect_count Then
           With oShape.Fill
             .Visible = msoTrue
             .ForeColor.ObjectThemeColor = msoThemeColorAccent6
             .ForeColor.TintAndShade = 0
             .ForeColor.Brightness = -0.5
             .Transparency = 0
             .Solid
          End With
          Exit For
        End If
        shape_count = shape_count + 1
    Next
    
    
       
    
    
    
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
            If Not Intersect(Range("H18:K28"), sh.TopLeftCell) Is Nothing And _
               Not Intersect(Range("H18:K28"), sh.BottomRightCell) Is Nothing Then
                sh.Delete
            End If
        Next sh
    

   
    Application.ScreenUpdating = True 'Turns Screen Updating back on
End Sub

Andrew Poulsom · Jul 14, 2014

A data validation dropdown is a shape.

Deleting all pictures / shapes in a range

toboggan

Board Regular

toboggan

Board Regular

Excel Facts

toboggan

Board Regular

Andrew Poulsom

MrExcel MVP

toboggan

Board Regular

toboggan

Board Regular

toboggan

Board Regular

Andrew Poulsom

MrExcel MVP

toboggan

Board Regular

toboggan

Board Regular

Andrew Poulsom

MrExcel MVP

Similar threads

Forum statistics

Share this page

Deleting all pictures / shapes in a range

Board Regular

Board Regular

Excel Facts

Board Regular

MrExcel MVP

Board Regular

Board Regular

Board Regular

MrExcel MVP

Board Regular

Board Regular

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock