vba to add a shape at a specific cell location in Excel

This seems to be working for me. I added the debug statements at the end to display whether the shape's .Top and .Left are equal to the cell's .Top and .Left values.

For this, I had selected 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

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%.

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

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.

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.

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

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.