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

问：

我正在尝试将包含数据和形状的单元格范围从工作表 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

VBA Excel-2007

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

这是你正在尝试的吗？

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

输出

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

Vba exclude 2 shapes from selection by name

评论

评论