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

问题描述

我正在使用以下代码从“模板”工作表中复制第一行并粘贴到所有其他工作表的第一行。第一行包含需要保持相同大小的形状。

运行宏时，“模板”中的形状会在所有其他工作表上调整大小。因此，我使用此行 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

解决方法

请尝试下一个代码：

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,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,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