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

Answer 3

我正在使用Office 365 64位Windows 10进行测试，并且该错误似乎仍然存在。此外，即使缩放比例为100％，我也能看到它。

我的解决方案是在纸上放置一个隐藏的样品形状。在我的代码中，我复制示例，然后选择要放入的单元格并粘贴。它始终准确落在该单元格的左上角。然后，您可以使其可见，并将其相对于其自身的顶部和左侧定位。

dim shp as shape
set shp = activesheet.shapes("Sample")

shp.copy
activesheet.cells(intRow,intCol).select
activesheet.paste

'after a paste, the selection is what was pasted
with selection
  .top = .top + 3  'position it relative to where it thinks it is
end with

Answer 4

Public Sub MoveToTarget()
    Dim cRange As Range
    Set cRange = ActiveCell
    Dim dLeft As Double, dTop As Double
    dLeft = cRange.Offset(0, 1).Left + (cRange.Width / 2) ' - ActiveWindow.VisibleRange.Left + ActiveWindow.Left
    If dLeft > Application.Width Then dLeft = cRange.Offset(0, -10).Left
    dLeft = dLeft + Application.Left
    '.Top = CommandBars("Ribbon").Height / 2
    dTop = cRange.Top '(CommandBars("Ribbon").Height / 2) + cRange.Top ' cRange.Top ' - ActiveWindow.VisibleRange.Top - ActiveWindow.Top
    If dTop > Application.Height Then dTop = cRange.Offset(-70, 0)
    'dTop = dTop + Application.Top
    ActiveSheet.Shapes.AddShape(msoShapeOval, dLeft, dTop, 200, 100).Select
End Sub

Answer 5

我在Excel 2019中工作时遇到此错误。 我发现将显示设置从最佳外观更改为兼容性可以解决此问题。 如果有人遇到相同的问题，我也愿意分享。

Answer 6

我的想法是，不是更改缩放，而是可以为每一行添加一个快速循环，直到单元格所在的行。 并添加每行的顶部，

之类的东西

dim c as range, cTop as double
for each c in Range("C1:C2")
    cTop=cTop + c.top
    next c

和最后一个细胞的高度。