11

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

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

4

6 回答 6

15

这似乎对我有用。我在末尾添加了调试语句以显示形状的.Top和.Left是否等于单元格的.Top和.Left值。

为此，我选择了 cell 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
于 2013-04-16T13:56:06.937 回答
6

我发现此问题是由仅在缩放级别不是 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
于 2017-01-25T03:55:09.550 回答
1

我正在使用 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
于 2019-03-08T17:07:23.287 回答
0 
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
于 2018-11-21T22:18:29.213 回答
0

在此处输入图像描述

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

于 2019-06-18T20:07:48.243 回答
-1

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

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

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

于 2018-05-13T07:13:09.243 回答