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

Question

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.

Answer 1

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