时间戳

首页 > 解决方案 > VBA Shape.Placement 属性仍然允许调整大小

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

问题描述

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

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

标签： excelvbaplacement

解决方案

请尝试下一个代码：

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

推荐阅读