Excel Vba通过名称将2个形状从选择中排除

问题描述

我试图从第一个工作表复制包含数据和形状的单元格范围，到工作簿中的所有其他工作表。但是需要通过名称将2个形状排除在选择之外，其他形状需要包含在内。

我已经尝试通过名称设置形状， visible = False 在复制之前，但它们仍然被复制了。

我还尝试将它们包含在粘贴的数据中，然后将它们设置为 visible=false 或从所有其他工作表中删除它们。但是一旦粘贴，形状的命名就不一致了。有时它们是相同的，有时它们递增到下一个可用的命名。

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

没有错误，但是所有的形状，包括那两个需要排除的形状，仍然被复制了。

以下是我尝试过的方法。我应该如何解决这个问题？

    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

解决方案

逻辑：

创建一个数组来存储要排除的形状的名称及其宽度和高度的细节。
在复制之前，将要排除的形状的宽度和高度设置为 0 。
复制该范围并粘贴。
将形状的宽度和高度（在主范围内）重置为原来的值。
遍历所有形状，删除宽度和高度为 0 的形状，这些形状不在复制的范围内。我可以省略 Intersect 步骤，但我保留它进行测试。我可以简单地删除所有宽度和高度为 0 的形状。

这符合您的要求吗？

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    '~~> Set this to the relevant sheet
    Set ws = Sheet1

    '~~> This array will store the details of the shapes
    '~~> That you would like to exclude
    Dim ArShapes() As String
    Dim CountOfShapesToBeExculded As Long
    CountOfShapesToBeExculded = 2
    ReDim ArShapes(1 To CountOfShapesToBeExculded, 1 To 3)

    '~~> Let's say we want to exclude these two shapes
    '~~> Get their details in the array
    ArShapes(1, 1) = "Oval 1"                   '<~~ Name of the shape
    ArShapes(1, 2) = ws.Shapes("Oval 1").Width     '<~~ Width
    ArShapes(1, 3) = ws.Shapes("Oval 1").Height    '<~~ Height

    ArShapes(2, 1) = "Teardrop 4"
    ArShapes(2, 2) = ws.Shapes("Teardrop 4").Width
    ArShapes(2, 3) = ws.Shapes("Teardrop 4").Height

    Dim i As Long

    '~~> Before copying, set the width and height to 0
    For i = LBound(ArShapes) To UBound(ArShapes)
        With ws.Shapes(ArShapes(i, 1))
            .Width = 0
            .Height = 0
        End With
    Next i

    'Debug.Print ws.Shapes.Count

    '~~> Perform the copy and paste
    Dim rng As Range
    Set rng = ws.Range("A1:H16")
    rng.Copy ws.Range("M1")

    '~~> Set the width and height back to normal
    For i = LBound(ArShapes) To UBound(ArShapes)
        With ws.Shapes(ArShapes(i, 1))
            .Width = ArShapes(i, 2)
            .Height = ArShapes(i, 3)
        End With
    Next i

    'Debug.Print ws.Shapes.Count

    Dim shp As Shape

    '~~> Delete the shape whose width and height is 0 which are not a
    '~~> part of the copied range
    For Each shp In ws.Shapes
        If Intersect(ws.Range(shp.TopLeftCell.Address), rng) Is Nothing Then
            If shp.Width = 0 Then shp.Delete
        End If
    Next shp

    'Debug.Print ws.Shapes.Count
End Sub

输出

Excel Vba通过名称将2个形状从选择中排除