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

我正在尝试在特定的单元格位置添加一个形状，但由于某些原因无法在所需的位置添加形状。 下面是我用来添加形状的代码：

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 

我使用variables来捕获左侧和顶部的位置，以检查在我的代码中设置的值与我在录制macros时在活动位置手动添加形状时看到的值。 当我运行我的代码时，cellleft = 414.75和celltop = 51，但是当我loggingmacros时手动添加形状到活动单元位置，cellleft = 318.75和celltop = 38.25。 我一直在解决这个问题，并且在线查看了很多关于添加形状的问题，但我无法弄清楚。 任何帮助将不胜感激。

Answer 1

这似乎是为我工作。 我在最后添加了debugging语句，以显示形状的.Top和.Left是否等于单元格的.Top和.Left值。

为此，我select了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.ScreenUpdatinf来防止闪烁。

 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