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

f2uvfpb9 于 2023-10-21 发布在其他

关注(0)|答案(1)|浏览(126)

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

excel

来源：https://stackoverflow.com/questions/77334932/vba-exclude-2-shapes-from-selection-by-name

1条答案

按热度按时间

aiazj4mn1#

逻辑：

1.创建一个数组来存储形状的（* 要排除）名称及其宽度和高度详细信息。
1.复制前将形状的宽度和高度（要排除）设置为0。
1.复制范围并粘贴。
1.将形状的宽度和高度（在主范围内 *）重置回原来的大小。
1.循环遍历所有形状并删除宽度和高度为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

输出

赞(0）回复(0）举报 2023-10-21

我来回答

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

1条答案

相关问题

热门标签

最新问答