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

【问题标题】：vba to add a shape at a specific cell location in Excelvba 在 Excel 中的特定单元格位置添加形状
【发布时间】：2013-04-16 13:49:46
【问题描述】：

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

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。我已经对此进行了一段时间的故障排除，并且在网上查看了很多关于添加形状的现有问题，但我无法弄清楚这一点。任何帮助将不胜感激。

【问题讨论】：

上面的代码对我来说完全没问题。
.Activate 在第一行并不一定意味着它等于选择然后......你需要检查它。或者直接在第一行将.Activate 更改为.Select。
我也有同样的问题。 .Cell.Left 和形状的真实位置之间有一点区别。此“错误”仅出现在 excel 2007 上。在 excel 2003 上，vba 代码运行良好。 2010年我不知道。我尝试了 Debug.Print 但我没有看到任何效果。
您是否使用了不同于 100% 的缩放比例？我发现使用缩放时形状位置存在绘图错误。（在 excel 2016 上测试）

标签： excel vba

【解决方案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

【讨论】：

我添加了您的调试部分，形状和单元格左侧和顶部都相同，所以我不知道为什么它不起作用。我保存了工作簿，关闭了 Excel，然后重新打开它，然后它工作正常，所以不太确定是什么问题，但感谢您的回答。
问题是您的缩放不是 100%。任何缩放更改，此代码都将不起作用。

【解决方案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

【讨论】：

【解决方案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

【讨论】：

【解决方案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

【讨论】：

只显示代码的答案不是很好。考虑提供一些信息来教发布问题的人。

【解决方案5】：

我在 Excel 2019 中遇到了这个错误。我发现将显示设置从最佳外观更改为兼容性解决了这个问题。我分享这个以防有人遇到同样的问题。

【讨论】：

【解决方案6】：

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

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

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

【讨论】：

问题是当缩放不是 100% 时，你得到的 c.top 是错误的，所以这不起作用。此外，这比简单地改变缩放需要更长的时间......
试试这个代码（分两部分） 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
我认为微软修复了这个错误，因为它不再发生了。我刚刚进行了测试，现在形状似乎已定位在应有的位置。