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

以及用於尺寸標注的最后一個單元格的高度。