Vba 按名称从选择中排除 2 个形状

Question

我正在尝试将包含数据和形状的一系列单元格从工作表 1 复制到工作簿中的所有其他工作表。但是，需要按名称从选择中排除 2 个形状。

我已经尝试在复制之前按名称将形状设置为

visible = False

，但它们仍然被复制。

我还尝试将它们包含在粘贴的数据中，然后将它们设置为

visible=false

或从所有其他工作表中删除它们。然而，粘贴后形状的命名并不一致。有时它们是相同的，有时它们会增加到下一个可用的。

在我看来，最好的方法是在复制之前从单元格范围中减去特定的形状范围，但是我无法让它工作。

没有错误，但所有形状，包括指定的 2 个形状，仍然被复制。

这是我尝试过的。我该如何解决这个问题？

    Dim TopRow As Range
    Dim arShapes() As Variant
    Dim ws As Worksheet
    Dim cellRange As Range
    Dim shapeRange As Range
    Dim resultRange As Range
    Dim shp As Shape
    Dim cell As Range
    
    ' Define the worksheet and cell range
    Set ws = Worksheets("Sheet1")
    Set TopRow = ws.Range("1:1")
    ' Set TopRow = Worksheets("Sheet1").Range("1:1")
    
    ' Define the shapes to subtract
    arShapes = Array("Button 1", "Oval 7")
    
    ' Set the cell range to be the entire top row
    Set cellRange = TopRow
    
    ' Initialize the resultRange with the cellRange
    Set resultRange = ws.Range(cellRange.Address)

    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Sheet1" Then
                       
            For Each shp In ws.Shapes
                If IsInArray(shp.Name, arShapes) Then
                    ' Check if the shape intersects with the resultRange
                    If Not Intersect(shp.TopLeftCell, resultRange) Is Nothing Then
                        ' Subtract the shape's range from the resultRange
                        Set resultRange = Application.Union(resultRange, shp.TopLeftCell)
                    End If
                End If
            Next shp
            
            resultRange.Copy
            
            ws.Range(cellRange.Address).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            ws.Paste
        End If
    Next ws

Answer 1

复印前将

Application.CopyObjectsWithCells

设置为

False

。这不会复制形状。

然后在代码末尾，将其设置回

True

。

由于我正在“玩”事件，所以最好使用错误处理。

Sub Sample()
    On Error GoTo Whoa
    
    Application.CopyObjectsWithCells = False
    
    'Rest of your code to Copy
    
LetsContinue:
    Application.CopyObjectsWithCells = True
    
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub