根据单元格值移动形状

时间:2019-10-28 17:43:48

标签: excel vba

第一张图片中的里程碑是里程碑工作表中的里程碑,第二张图片中的计划工作表中,条上的三角形形状将随参考日期一起移动(C5)来自里程碑工作表。 这些里程碑应根据计划工作表上的值正确引用。 例如。里程碑工作表c5 = 6月14日,应在单元格M12中的条形上方将三角形放置一行,即计划工作表中的6月14日。其他里程碑也必须这样做。

我是VBA的新手,我尝试了一些方法,但是没有运行。 我猜我的细胞范围选择是错误的。 代码如下:

Sub Check()
    Dim rng As Range
    Set rng = Sheets("Gleichschenkliges Dreieck 1").Range("H$10:cm$10")
    For Each cell In rng  
    If cell.Value <> "" Then
            Set rng = Range("C13").End(xlToRight).Offset(0, 1)
            ActiveSheet.Shapes("Gleichschenkliges Dreieck 1").Left = rng.Left
    End If
    Next
End Sub

enter image description here enter image description here

1 个答案:

答案 0 :(得分:0)

不是解决方案,而是一个指针,但希望它必须提供格式。

我必须做一些工作才能使match函数正常工作,您可以在此处使用.find或类似的方法。希望这对您有所帮助或对您有所启发。

Sub test_ct()

Dim r As Excel.Range
Dim r2 As Excel.Range
Dim l As Long
Dim s As Shape
Dim d As Date

d = CDate("01/05/2019")

'   Range of my dates at the top
Set r = Sheets("Sheet10").Range("c1:o1")
'   The shape i want to move
Set s = Sheets("Sheet10").Shapes("Triangle1")

'   Set default position
s.Left = 10

'   Get the column of this date, MATCH intended here, but failing on dates.
l = Application.WorksheetFunction.Match(CDbl(CDate("01/05/2019")), r, 0)

'   Destination plus 1/2 width, needs fine tuning, to find centre
l = r(1, l).Left
l = l + (r(1, l).Width / 4)

'   Move the shape
s.Left = l


End Sub