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

以及用于尺寸标注的最后一个单元格的高度。