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

问题:

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.

回答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)  '

回答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.ScreenUpdatinf 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 

文章来源: vba to add a shape at a specific cell location in Excel