VBA Shape.Placement 属性 仍然允许调整大小

Question

我正在使用下面的代码从 sheet“模板复制第一行并粘贴到所有其他 sheet 的第一行。第一行包含需要保留的形状大小一样。

当宏为 运行 时，“模板”中的形状会在所有其他 sheet 上调整大小。因此，我用 Shp.Placement = xlFreeFloating.

这一行设置了位置 属性

但是，它们在粘贴过程中会继续调整大小。但是，在粘贴它们之后，如果更改单元格大小，它们将不再调整大小。

如何防止形状在首次粘贴时调整大小？

    Dim ws As Worksheet
    Dim HeaderRow As Range
    Dim Shp As Shape

    Set HeaderRow = Worksheets("Template").Range("1:1")
    
    For Each ws In ActiveWorkbook.Worksheets

        For Each Shp In ws.Shapes
            Shp.Placement = xlFreeFloating 
        Next Shp

        If ws.Name <> "Template" Then
            For Each Shp In ws.Shapes
                If Shp.TopLeftCell.Row = 1 Then
                    Shp.Delete 'Delete shapes before pasting or they multiply
                End If
            Next Shp
            
            HeaderRow.Copy
            
            ws.Range(HeaderRow.Address).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            ws.Paste

        End If
    Next ws

Answer 1

请尝试下一个代码：

Sub copyShapesMove()
  Dim ws As Worksheet, wsT As Worksheet, HeaderRow As Range, Shp As Shape

    Set wsT = Worksheets("Template")
    Set HeaderRow = wsT.Range("1:1")
    'set the header shapes placement property BEFORE COPYING:
    For Each Shp In wsT.Shapes
        If Not Intersect(Shp.TopLeftCell, HeaderRow) Is Nothing Then
            Shp.placement = xlMove
        End If
    Next
    For Each ws In ActiveWorkbook.Worksheets

        If ws.Name <> "Template" Then
            For Each Shp In ws.Shapes
                If Shp.TopLeftCell.row = 1 Then
                    Shp.Delete 'Delete shapes before pasting or they multiply
                End If
            Next Shp
            
            HeaderRow.Copy
            
            ws.Range(HeaderRow.Address).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            ws.Paste
        End If
    Next ws
End Sub

已编辑:

以上代码仅适用于比 Excel 2007 更新的版本，它看起来有一个错误并且不关心（在 VBA 中）“移动但不调整单元格大小” 属性。因此，以下代码将要复制的形状维度放在一个数组中，并在复制后调整复制形状的大小：

Sub copyShapesSameDimensions()
  Dim ws As Worksheet, wsT As Worksheet, HeaderRow As Range, Shp As Shape
  Dim arrSh, k As Long, El, arrProp

    Set wsT = Worksheets("Template")
    Set HeaderRow = wsT.Range("1:1")
    'Put the shapes to be copied dimensions in an array:
    ReDim arrSh(wsT.Shapes.Count - 1)
    For Each Shp In wsT.Shapes
        If Shp.TopLeftCell.Row = 1 Then
            arrSh(k) = Shp.Name & "|" & Shp.Width & "|" & Shp.Height & "|" & Shp.Left: k = k + 1
        End If
    Next
    ReDim Preserve arrSh(k - 1)

    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Template" Then
            For Each Shp In ws.Shapes
                If Shp.TopLeftCell.Row = 1 Then
                   Shp.Delete
                End If
            Next Shp
            
            HeaderRow.Copy
            
            ws.Range(HeaderRow.Address).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            ws.Paste

            'put the dimensions back on each shape:
            For Each El In arrSh
                arrProp = Split(El, "|")
                For Each Shp In ws.Shapes
                    If Shp.TopLeftCell.Row = 1 Then
                        If Shp.Name = arrProp(0) Then
                            Shp.Width = CDbl(arrProp(1))
                            Shp.Height = CDbl(arrProp(2))
                            Shp.Left = CDbl(arrProp(3))
                            Exit For
                        End If
                End If
                Next
            Next El
        End If
    Next ws
End Sub