如何解决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
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。