0 votes
in VBA by Beginner (10 points)

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 (916 points)
Hello Steve

Can you upload sample workbook instead of just snapshot?
by Beginner (10 points)
edited by

Hello, Here is the uploaded spreadsheet..


Thanks for any help..


2 Answers

+2 votes
by Expert (916 points)
selected by
Best answer


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
    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
Wow!!   Thank you very much.. This works great.

This website is Awesome..

Thanks again.
by Expert (916 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 (916 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 (485 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

    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.





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


by Skilled (485 points)
Hi Steve,

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

This community is awesome!





Welcome to wellsr Q&A
Ask any questions you have about VBA and Python and our community will help answer them. wellsr Q&A is the standalone question and answer platform for wellsr.com. If you have a question about one of our specific tutorials, please include a link back to the tutorial.

Getting Started
VBA Cheat Sheets (On Sale Now)

Looking for something else? Hire our team directly through ourVBA Help page, instead.

For more programming tips visit the VBA Tutorials Blog and the Python Tutorials Blog.