Excel VBA求助：插入新形状后旧形状移位，设置Placement仍无效

你的代码存在两个核心问题导致原有形状偏离位置：

• 每次运行代码时都会执行ActiveSheet.Shapes("SigPlus" & x).IncrementTop 4.5651968504，这会让目标形状累加向下偏移指定距离，多次运行后偏移量会持续增大。
• 你尝试设置的Placement属性未在代码中实际生效，且如果需要形状固定在单元格内，xlFreeFloating并非合适选项——它会让形状完全脱离与单元格的关联。

1. 移除增量偏移语句 #

直接删除IncrementTop相关代码，避免每次运行都累加位置偏移。

2. 正确设置形状的单元格关联属性 #

根据你“形状位于单元格内并保持位置不变”的需求，选择对应的Placement属性：

• xlMoveAndSize：形状随单元格移动并同步调整大小（适合完全绑定单元格的场景）
• xlMove：形状随单元格移动但不调整大小
• xlFreeFloating：形状完全独立于单元格（仅当不需要与单元格关联时使用）

3. 可选：精准对齐到目标单元格 #

如果需要形状始终固定在特定单元格位置，可以通过获取单元格的Top和Left坐标来强制对齐。

Option Explicit
Public Sub ResizePicture()
    Dim x As Integer
    Dim targetShape As Shape
    Dim targetCell As Range ' 可选：用于绑定到特定单元格
    
    For x = 1 To 35
        On Error GoTo endProc
        Set targetShape = ActiveSheet.Shapes("SigPlus" & x)
        
        ' 设置固定尺寸
        targetShape.Height = 32.5984251969
        targetShape.Width = 113.3858267717
        
        ' 设置形状与单元格的关联方式（按需选择）
        targetShape.Placement = xlMoveAndSize ' 可替换为 xlMove 或 xlFreeFloating
        
        ' 可选：将形状精准对齐到指定单元格（示例为A列第x行）
        Set targetCell = ActiveSheet.Cells(x, "A")
        targetShape.Top = targetCell.Top
        targetShape.Left = targetCell.Left
        
    Next x
    
endProc:
    Exit Sub
End Sub

• 移除IncrementTop语句，彻底消除重复偏移的根源
• 新增targetShape变量，简化代码结构并减少重复调用
• 加入Placement属性设置，确保形状与单元格的关联符合需求
• 可选的单元格对齐代码，能让形状始终固定在目标单元格位置，彻底解决偏移问题

内容的提问来源于stack exchange，提问作者Zerlie Ann Palaac