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

Answer 2

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 = ActiveWindow.Zoom
Application.ScreenUpdating = False
ActiveWindow.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

ActiveWindow.Zoom = oldZoom 'Restore previous zoom
Application.ScreenUpdating = True

Answer 3

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

Answer 4

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.

Answer 5

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 6

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.