vba vba在Excel中的特定单元格位置添加形状
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/16038893/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
vba to add a shape at a specific cell location in Excel
提问by Casey
I am trying to add a shape at a specific cell location but cannot get the shape added at the desired location for some reason. Below is the code I am using to add the shape:
我正在尝试在特定单元格位置添加形状，但由于某种原因无法在所需位置添加形状。下面是我用来添加形状的代码：
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
I used variables to capture the left and top positions to check the values that were being set in my code vs. the values I saw when adding the shape manually in the active location while recording a macro. When I run my code, cellleft = 414.75 and celltop = 51, but when I add the shape manually to the active cell location while recording a macro, cellleft = 318.75 and celltop = 38.25. I have been troubleshooting this for a while and have looked over a lot of existing questions online about adding shapes, but I cannot figure this out. Any help would be greatly appreciated.
我使用变量来捕获左侧和顶部位置，以检查在我的代码中设置的值与我在录制宏时在活动位置手动添加形状时看到的值。当我运行我的代码时，cellleft = 414.75 和 celltop = 51，但是当我在录制宏时手动将形状添加到活动单元格位置时，cellleft = 318.75 和 celltop = 38.25。我已经对此进行了一段时间的故障排除，并在网上查看了许多有关添加形状的现有问题，但我无法弄清楚这一点。任何帮助将不胜感激。
回答by David Zemens
This seems to be working for me. I added the debug statements at the end to display whether the shape's .Topand .Leftare equal to the cell's .Topand .Leftvalues.
这似乎对我有用。我在最后添加了调试语句以显示形状的.Top和.Left是否等于单元格的.Top和.Left值。
For this, I had selected cell C2.
为此，我选择了 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
回答by cyberponk
I found out this problem is caused by a bug that only happens when zoom level is not 100%. The cell position is informed incorrectly in this case.
我发现这个问题是由一个只有在缩放级别不是 100% 时才会发生的错误引起的。在这种情况下，单元位置被错误地通知。
A solution for this is to change zoom to 100%, set positions, then change back to original zoom. You can use Application.ScreenUpdating to prevent flicker.
对此的解决方案是将缩放更改为 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
回答by Steve Bull
I'm testing with Office 365 64 bit, Windows 10, and it looks like the bug persists. Furthermore, I'm seeing it even when zoom is 100%.
我正在使用 Office 365 64 位、Windows 10 进行测试，看起来错误仍然存在。此外，即使缩放为 100%，我也能看到它。
My solution was to place a hidden sample shape on the sheet. In my code, I copy the sample, then select the cell I want to place it in, and paste. It always lands exactly in the upper left corner of that cell. You can then make it visible, and position it relative to its own top and left.
我的解决方案是在工作表上放置一个隐藏的样本形状。在我的代码中，我复制示例，然后选择要放置它的单元格并粘贴。它总是恰好落在该单元格的左上角。然后，您可以使其可见，并将其相对于其自身的顶部和左侧定位。
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
回答by Gabriel B
I had this error working in the Excel 2019. I've found that changing the display settings from best appearance to compatibility solved the issue. I share this in case someone has the same problem.
我在 Excel 2019 中遇到了这个错误。我发现将显示设置从最佳外观更改为兼容性解决了这个问题。我分享这个以防有人遇到同样的问题。
回答by Hans
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
回答by Hans
My idea is instead of changing the zoom, you can add a quick loop to for each row until the row where the cell is. and add the tops of each row, something like
我的想法是，您可以为每一行添加一个快速循环，直到单元格所在的行，而不是更改缩放比例。并添加每行的顶部，例如
dim c as range, cTop as double
for each c in Range("C1:C2")
cTop=cTop + c.top
next c
and the height of the last cell for dimenssioning.
以及用于尺寸标注的最后一个单元格的高度。
