# Line that moves based on current date.

in VBA

Hello, I have a spreadsheet that I use to track projects.

What I would like, is to have the Red Vertical Line and Arrow move to the current date location OnOpen.

(See screenshot...) link here if it doesn't show below: https://www.screencast.com/t/KSEX8Uek Thank you, Steve

by Expert (848 points)
Hello Steve

by Beginner (10 points)
edited by

Thanks for any help..

Steve

by Expert (848 points)
selected by

Hello

Based on Mitch's solution ..

Group the two shapes to be one as illustrated byMitch then try this code

``````Sub Test()
Dim x, dt As Date, sMonth As String, y

dt = Date
x = Application.Match(Year(Date) & ":", Rows(6), 0)

If Not IsError(x) Then
sMonth = Choose(Month(dt), "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
y = Application.Match(sMonth, Cells(7, x).Resize(, 48), 0)
If Not IsError(y) Then
ActiveSheet.Shapes("PointToday").Left = Cells(7, x + y - 1 + GetPart(dt)).Left - 8
Application.Goto Cells(1, x + y - 1 + GetPart(dt) - 3), True
End If
End If
End Sub

Function GetPart(dtm As Date) As Long
'https://www.eileenslounge.com/viewtopic.php?f=30&t=33766
Dim d As Long, n As Long

d = Day(dtm): n = Day(DateSerial(Year(dtm), Month(dtm) + 1, 0))

Select Case n
Case 28
Case 29
d = d + (d > 28)
Case 30
d = d + (d > 15) + (d > 23)
Case 31
d = d + (d > 14) + (d > 22) + (d > 30)
End Select

GetPart = (d - 1) \ 7 + 1
End Function``````

by Beginner (10 points)
edited by
+2
Wow!!   Thank you very much.. This works great.

This website is Awesome..

Thanks again.
by Expert (848 points)
You're welcome. Glad I can offer some help.

Thanks a lot for Mitch too. He inspired me.
by Beginner (10 points)

Hello, I do have a question..

I'm reading thorugh the code, can you help me understand what this part is doing.

``````ActiveSheet.Shapes("PointToday").Left = Cells(7, x + y - 1 + GetPart(dt)).Left - 8
Application.Goto Cells(1, x + y - 1 + GetPart(dt) - 3), True``````

Thanks again..

by Expert (848 points)
The whole code depends on using Match to match first the year from the row of years then to match the month from the range that is related to that year .. All this to determine the cell address on which the line will be moved to. As for each month you have designed four parts so there is a UDF that determine the date's part so as to be on the right column when running the code and at last using Goto to be on the spot of the desired column.
+1 vote
by Skilled (355 points)

Hi Steve,

This can be done in one of two ways. If both the line and arrow always move together, the first thing you want to do is to select each one and, under the Drawing Tools menu, select Group. With both of them selected, go over to the name bar and change the name from the default "Group n" to PointToday.  Now in the Workbook_Open event, place this code:

``````Private Sub Workbook_Open()

Const ShiftBoth = 6.1

ActiveSheet.Shapes.Range(Array("PointToday")).Select
Selection.ShapeRange.IncrementLeft ShiftBoth

End Sub
``````

The constant, ShiftBoth, was set to 6.1, based on your screenshot showing a single letter in each column name. If the line and arrow move too much, realign them to the previous day, reduce the constant, save the workbook and close it. Re-open to test the new distance.

The second way is required if, for some reason, the line and arrow move independently. In this case, you need a separate set of instructions. However, the increment really can't be calculated. Instead, you will have to use Selection.ShapeRange.Left = value, where value is calculated as some constant, multiplied by the number of days from Day 1.

Cheers,

Mitch

by Beginner (10 points)
Hello Mitch, thanks for your input as well..

Steve
by Skilled (355 points)
+1
Hi Steve,

You're welcome. I love how Yasser took it to another level.

This community is awesome!

Cheers,

Mitch