Clear specified range of contents and shapes - excel

Question

I need to remove all the content from a specific cell range (Y1:CZ100) in a worksheet (Drawing) and reset all cell's borders linestyles, fill color etc to none. The range can have different content but will always be populated with various group objects and autoshapes as well as text, merged cells and cell borders/fill colour etc. I've written the following macro to do this:
Option Explicit
Sub Remove_DOD() 'Remove Drive on Dock drawing, Product Count Table, reset formulae
Dim sh As Shape
Dim DrawRange As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Remove DOD Drawing and Product Count table)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Worksheets("Drawing")
Application.ScreenUpdating = False
Set DrawRange = Range("Y1:CZ100")
With DrawRange
.UnMerge
.Interior.Color = xlNone
.Borders.LineStyle = xlNone
.ClearContents
End With
For Each sh In .Shapes
If Not Application.Intersect(sh.TopLeftCell, DrawRange) Is Nothing Then
If sh.Type = msoGroup Or sh.Type = msoAutoShape Then sh.Delete
End If
Next sh
Application.ScreenUpdating = True
End With
End Sub
It works most of the time but will sometimes fail with Run-time error '1004': Application-defined or object-defined error at the statement If Not Application.Intersect(sh.TopLeftCell, DrawRange) Is Nothing Then and I cannot figure out what causes it to happen. When the error does occur, the With loop to clearcontent, unmerge etc always completes but some group items are still present in the range and other times they are all cleared.
Any insights as to a solution would be most welcome.
Update:
I tried changing the method for selecting the shapes to be deleted and stopped testing for the type of shape (since all in the range need to be deleted). This is the code but it still sometimes fails with same Run-time error 1004 at s = .TopLeftCell.Address & ":" & .BottomRightCell.Address. The error seems to occur only after the contents of the Drawing range have been replaced with new shapes and the macro is run again. Sometimes it errors immediately and none of the new shapes are deleted but it can also be when and it has reached the end of deleting all these new shapes (i.e. on the last iteration of With sh). I think the error is because the value of sh is invalid but don't see why this happens. Perhaps I need to insert some way of testing the value of sh? Also, I have seen old posts on other forums with similar issues but solutions never provided.
Option Explicit
Sub Remove_DOD() 'Remove Drive on Dock drawing, Product Count Table, reset formulae
Dim sh As Shape
Dim S As String
Dim DrawRange As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Remove DOD Drawing and Product Count table)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Worksheets("Drawing")
Application.ScreenUpdating = False
Set DrawRange = Range("Y1:CZ100")
With DrawRange
.UnMerge
.Interior.Color = xlNone
.Borders.LineStyle = xlNone
.ClearContents
End With
For Each sh In .Shapes
With sh
s = .TopLeftCell.Address & ":" & .BottomRightCell.Address
End With
If Not Intersect(DrawRange, .Range(s)) Is Nothing Then
sh.Delete
End If
Next
Application.ScreenUpdating = True
End With
End Sub
This fails the same way at Set shRange = Range(sh.TopLeftCell.Address & ":" & sh.BottomRightCell.Address) statement:
Option Explicit
Sub Remove_DOD() 'Remove Drive on Dock drawing, Product Count Table, reset formulae
Dim sh As Shape
Dim s As String
Dim DrawRange, shRange As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Remove DOD Drawing and Product Count table)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Worksheets("Drawing")
Application.ScreenUpdating = False
Set DrawRange = Range("Y1:CZ100")
With DrawRange
.UnMerge
.Interior.Color = xlNone
.Borders.LineStyle = xlNone
.ClearContents
End With
For Each sh In .Shapes
Set shRange = Range(sh.TopLeftCell.Address & ":" & sh.BottomRightCell.Address)
If Not Intersect(shRange, DrawRange) Is Nothing Then sh.Delete
Next
Application.ScreenUpdating = True
End With
End Sub
Not very satisfactory but the following now works. Note the inclusion of On Error Resume Next in the For Each sploop. This forces the loop to exit when the error is encountered.
Option Explicit
Sub Remove_DODTest() 'Remove Drive on Dock drawing, Product Count Table, reset formulae
Dim sh As Shape
Dim DrawRange As Range
With Worksheets("Drawing")
Application.ScreenUpdating = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Remove DOD Drawing and Product Count table
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set DrawRange = .Range("Y1:CZ100")
With DrawRange
.UnMerge
.Interior.Color = xlNone
.Borders.LineStyle = xlNone
.ClearContents
End With
For Each sh In .Shapes
On Error Resume Next
If Not Application.Intersect(sh.TopLeftCell, DrawRange) Is Nothing Then sh.Delete
Next sh
End With
Application.ScreenUpdating = True
End Sub