利用VBA程序将形状放到指定位置

hq00

我有一个表格,在第6行有很多日期,我希望每次打开表格运行VBA程序(ftest11)的时候,在当天日期的位置画一个红色方框,
Today = CDate(Now())      '获取当前日期

在今天(6.28日)这儿画的位置比较精准,

可是当我模仿10天(Today = CDate(Now() + 10)  )或更多天后的情形,位置就偏离了.距离今天越远,偏移的越严重,请各位高手看看问题出自哪里?

小凡、、、

在wps和365版本中测试，没有截图那么明显的偏差

半百

测试了，没有你说的情况

hq00

我使用的是office365，你们试试20天或30天以后的情况呢？

wtg321

测试后没发现有问题。

1. Sub ftest11()
   
2. Dim ShpRec, Shp As Shape
   
3. Dim colIndex, Left_position As Integer
   
4. Dim Today As Date
   
5. Set CurSht = Worksheets("工作统计表")
   
6. For Each Shp In CurSht.Shapes       '删除页面所有的形状
   
7.     Shp.Delete
   
8. Next Shp
   
9. For i = 1 To 15
   
10. rq = Date + i
    
11. Set zhao = CurSht.Rows(6).Find(rq)
    
12. zhao.Select
    
13. Set ShpRec = CurSht.Shapes.AddShape(msoShapeRectangle, zhao.Left, zhao.Top - 1, zhao.MergeArea.Width, 492) '在当前日期处画矩形
    
14. ShpRec.Fill.Visible = msoFalse
    
15. With ShpRec.Line        '设置矩形外观
    
16.     .ForeColor.RGB = RGB(255, 0, 0)
    
17.     .Transparency = 0
    
18.     .Weight = 3
    
19.     .Visible = msoTrue
    
20. End With
    
21. Next
    
22. End Sub

复制代码

边缘码农

excel2016，测试了90天，没有任何偏移。

hq00

谢谢各位老师，特别是@wtg321将代码优化。是我的显示器的原因，程序基本没有大的毛病，问题已经解决。