简体   繁体   中英

Move Shape based on cell value

As in 1st image are milestone which is in milestone worksheet and 2nd image is of the plan worksheet where triangle shape on the bar is to be moved with the reference Dates (C5) from milestone worksheet. Those milestones should be properly referenced on value based on plan worksheet. Eg. Milestone worksheet c5 = June 14, triangle should be placed one row above the bar in cell M12 ie June 14 in Plan worksheet. And same has to be done to other milestones.

I am new to VBA i tried something, but it didn't run. i guess my cell range selection is wrong. Code is given below:

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

在此处输入图像描述在此处输入图像描述

Not a solution, a pointer, but wanted the formatting this had to offer.

I've had to do a bit of work to get the match function to work, you could use .find here or something similar. Hope this helps you or inspires you.

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

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM