Question

我需要从工作表（图形）中的特定单元格区域（Y1：CZ100）中删除所有内容，并将所有单元格的边框线型，填充颜色等重置为无。范围可以具有不同的内容，但始终会填充各种组对象和自动形状以及文本，合并的单元格和单元格边框/填充颜色等。我编写了以下宏来做到这一点：

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循环始终会完成，但是该范围中仍然存在某些组项，而其他时候它们都已清除。

任何对解决方案的见解都将受到欢迎。

更新：

我尝试更改选择要删除的形状的方法，并停止测试形状的类型（因为需要删除所有范围内的形状）。这是代码，但有时仍会失败，并且在Run-time error 1004处使用相同的s = .TopLeftCell.Address & ":" & .BottomRightCell.Address。仅在将Drawing范围的内容替换为新形状并再次运行宏之后，才会出现该错误。有时，它会立即出错，并且不会删除任何新形状，但是也可能是在删除所有这些新形状时（即在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。这会在遇到错误时强制循环退出。

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

清除指定范围的内容和形状

0 个答案: