vba在Excel中的特定单元格位置添加形状

Question

我试图在特定的单元格位置添加形状,但由于某种原因无法在所需位置添加形状.下面是我用来添加形状的代码:

Cells(milestonerow, enddatecellmatch.Column).Activate

Dim cellleft As Single
Dim celltop As Single
Dim cellwidth As Single
Dim cellheight As Single

cellleft = Selection.Left
celltop = Selection.Top

ActiveSheet.Shapes.AddShape(msoShapeOval, cellleft, celltop, 4, 10).Select

我使用变量来捕获左侧和顶部位置,以检查我的代码中设置的值与我在录制宏时在活动位置手动添加形状时看到的值.当我运行我的代码时,cellleft = 414.75并且celltop = 51,但是当我在录制宏时手动将形状添加到活动单元格位置时,cellleft = 318.75并且celltop = 38.25.我已经对此进行了一段时间的故障排除,并在网上查看了很多关于添加形状的现有问题,但我无法弄清楚这一点.任何帮助将不胜感激.

Answer 1

这似乎对我有用.我添加了调试语句末来显示形状的是否.Top和.Left等于细胞的.Top和.Left值.

为此,我选择了细胞C2.

Sub addshapetocell()

Dim clLeft As Double
Dim clTop As Double
Dim clWidth As Double
Dim clHeight As Double

Dim cl As Range
Dim shpOval As Shape

Set cl = Range(Selection.Address)  '<-- Range("C2")

clLeft = cl.Left
clTop = cl.Top
clHeight = cl.Height
clWidth = cl.Width

Set shpOval = ActiveSheet.Shapes.AddShape(msoShapeOval, clLeft, clTop, 4, 10)

Debug.Print shpOval .Left = clLeft
Debug.Print shpOval .Top = clTop

End Sub

Answer 2

我发现此问题是由仅在缩放级别不是100％时才发生的错误引起的。在这种情况下，错误地通知了单元位置。

一种解决方案是将缩放比例更改为100％，设置位置，然后再更改回原始缩放比例。您可以使用Application.ScreenUpdating防止闪烁。

Dim oldZoom As Integer
oldZoom = Wn.Zoom
Application.ScreenUpdating = False
Wn.Zoom = 100 'Set zoom at 100% to avoid positioning errors

  cellleft = Selection.Left
  celltop = Selection.Top
  ActiveSheet.Shapes.AddShape(msoShapeOval, cellleft, celltop, 4, 10).Select

Wn.Zoom = oldZoom 'Restore previous zoom
Application.ScreenUpdating = True