CODEWITHSUNDEEP
excelvba
Akshay
Akshay

Reputation: 21

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 i.e 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

enter image description here enter image description here

Upvotes: 0

Views: 1220

Answers (1)

Nathan_Sav
Nathan_Sav

Reputation: 8531

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

Upvotes: 1

Related Questions