Очистить указанный диапазон содержимого и форм

Question

Мне нужно удалить все содержимое из указанного диапазона ячеек c (Y1: CZ100) на рабочем листе (Рисование) и сбросить стили линий границ всех ячеек, закрасить цвет et c на ноль. Диапазон может иметь разное содержимое, но всегда будет заполняться различными групповыми объектами и автофигурами, а также текстом, объединенными ячейками и границами ячеек / цвет заливки и т. Д. c. Для этого я написал следующий макрос:

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

Он работает большую часть времени, но иногда не работает с Run-time error '1004': Application-defined or object-defined error в операторе If Not Application.Intersect(sh.TopLeftCell, DrawRange) Is Nothing Then, и я не могу понять, что вызывает это , Когда ошибка все же возникает, команда With l oop to clearcontent, unmerge et c всегда завершается, но некоторые элементы группы все еще присутствуют в диапазоне, а в других случаях все они очищаются.

Любые сведения о решение будет приветствоваться.

Обновление:

Я попытался изменить метод выбора удаляемых фигур и остановил тестирование для типа формы (поскольку все в диапазоне должны быть удален). Это код, но иногда он все равно не работает с тем же Run-time error 1004 на s = .TopLeftCell.Address & ":" & .BottomRightCell.Address. Похоже, ошибка возникает только после того, как содержимое области рисования было заменено новыми фигурами, и макрос запускается снова. Иногда происходит ошибка сразу, и ни одна из новых фигур не удаляется, но это также может быть, когда и когда достигнут конец удаления всех этих новых фигур (т. Е. На последней итерации With sh). Я думаю, что ошибка в том, что значение sh недопустимо, но не понимаю, почему это происходит. Возможно, мне нужно вставить какой-нибудь способ проверки значения sh? Кроме того, я видел старые сообщения на других форумах со схожими проблемами, но решения никогда не предлагались.

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

Это не так в выражении Set shRange = Range(sh.TopLeftCell.Address & ":" & sh.BottomRightCell.Address):

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

Не очень удовлетворительно, но теперь работает следующее. Обратите внимание на включение On Error Resume Next в For Each sp l oop. Это вынуждает l oop выйти при возникновении ошибки.

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