Dynamic width of the shape based on the day of the month [VBA]

[Martin_H]

Hi team,

I am looking for a help with this one.

If today is the first day of the month, then make Rectangle 1 = 0 cm width.
If today is the second day of the month, then make Rectangle 1 to cover the range area D6:D33.
If today is the third day of the month, then make Rectangle 1 to cover the range area D6:E33.
If today is the fourth day of the month, then make Rectangle 1 to cover the range area D6:F33.
If today is the fifth day of the month, then make Rectangle 1 to cover the range area D6:G33.
If today is the sixth day of the month, then make Rectangle 1 to cover the range area D6:H33.
... and so on till the last day of the month.

Rectangle 1 is just a basic Excel Rectangle shape.


Thank you very much.

 

[MartinS]

This will do what you need, but you'll have to figure out how to trigger it - auto open event maybe?

Dim intDayOfMonth   As Integer
Dim shp             As Shape
Dim rngShapeArea    As Range

    intDayOfMonth = Day(Now)-1
       
    Set rngShapeArea = ActiveSheet.Range("D6:D33")
    Set shp = ActiveSheet.Shapes("Rectangle 1")
   
    Select Case intDayOfMonth
        Case 0:
            shp.Width = intDayOfMonth
        Case Else
            shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth).Width
    End Select

 

[KOKOSEK]

I do not know how you want to use it, I suppose on opening the file, so put into ThisWorkbook:

Private Sub Workbook_Open()
With Sheets("Sheet1")
    .Shapes("Rectangle 1").Left = [D6].Left
    .Shapes("Rectangle 1").Top = [D6].Top
    .Shapes("Rectangle 1").Height = [D6:D33].Height
    If Day(Now) > 1 Then
        .Shapes("Rectangle 1").Width = .Range(Cells(1, 4), Cells(1, 4 + (Day(Now) - 2))).Width
    Else
        .Shapes("Rectangle 1").Width = 0
    End If
End With
End Sub

 

[Martin_H]

I forgot to mention that it will start automatically when the workbook is opened.

Both solutions work perfectly.

Marked first one as a solution.

Thank you @MartinS & @KOKOSEK, much appreciated

 

[Martin_H]

One more thing.

Cell D8 is always occupied with the first day of the month, currently there is 1.11.2021.


If in cell D8 is current month & current year (e.g. November 2021) your code will work exactly as it is above.

If in cell D8 is any previous month (e.g. October, May, March or whatever) or previous year (2020, 2019, 2018 or whatever) then make Rectangle 1 to cover whole range area D6:AH33.

If in cell D8 is any following month (e.g. December) or any following year (2022, 2023 or whatever) then make Rectangle 1 = 0 cm width.


Would it be possible to make this minor change @MartinS & @KOKOSEK?

Thank you guys!

 

[MartinS]

Sorry, not sure I understand what you are trying to do and quite how you want this changed.

If in cell D8 is any previous month

If in cell D8 is any following month

Are you saying that 01.11.2021 is an absolute fixed start date? If so, I'd suggest that is stored in VBA as a constant, then your quoted lines above will make sense, but if someone chnages D8 from 01.11.2021 to, say, 01.03.2022, how will the code know it's after 01.11?

 

[Martin_H]

D8 always show the first day of the current month. As I said above, D8 is now the first day of November, so 1.11.2021. D8 is formatted as a custom short date (d.m.yy)
The following month will automatically change D8 to the first day of December.
When December 2021 ends, and next year will start, D8 will be first day of January 2022 and so on.

I thought it could be somehow? done by determining from today() function.

If D8 value > today's month & year then Rectangle 1 = 0 cm width
If D8 value < today's month & year then make Rectangle 1 to cover range area D6:AH33
If D8 value = today's month & year then code above will be in charge

 

[MartinS]

Hopefully this does what you need...

Dim intDayOfMonth   As Integer
Dim intDaysInMonth  As Integer
Dim shp             As Shape
Dim rngShapeArea    As Range
Dim rngMonthDate    As Range

    intDayOfMonth = Day(Now)
       
    Set rngMonthDate = ActiveSheet.Range("D8")
    Set rngShapeArea = ActiveSheet.Range("D6:D33")
    Set shp = ActiveSheet.Shapes("Rectangle 1")
    'Calculate the days in the current month
    If Month(rngMonthDate.Value) = 12 Then
        intDaysInMonth = Day(DateSerial(Year(Now) + 1, 1, 1) - 1)
    Else
        intDaysInMonth = Day(DateSerial(Year(Now), Month(Now) + 1, 1) - 1)
    End If
    'Set the variable value if the dates don't match
    If Year(rngMonthDate.Value) > Year(Now) And Month(rngMonthDate.Value) > Month(Now) Then
        intDayOfMonth = 1
    ElseIf Year(rngMonthDate.Value) < Year(Now) And Month(rngMonthDate.Value) < Month(Now) Then
        intDayOfMonth = intDaysInMonth
    End If
    'Define the shape size
    Select Case intDayOfMonth
        Case 1:
            shp.Width = 0
        Case Else
            shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth - 1).Width
    End Select

 

[Martin_H]

Hopefully this does what you need...

Dim intDayOfMonth   As Integer
Dim intDaysInMonth  As Integer
Dim shp             As Shape
Dim rngShapeArea    As Range
Dim rngMonthDate    As Range

    intDayOfMonth = Day(Now)
      
    Set rngMonthDate = ActiveSheet.Range("D8")
    Set rngShapeArea = ActiveSheet.Range("D6:D33")
    Set shp = ActiveSheet.Shapes("Rectangle 1")
    'Calculate the days in the current month
    If Month(rngMonthDate.Value) = 12 Then
        intDaysInMonth = Day(DateSerial(Year(Now) + 1, 1, 1) - 1)
    Else
        intDaysInMonth = Day(DateSerial(Year(Now), Month(Now) + 1, 1) - 1)
    End If
    'Set the variable value if the dates don't match
    If Year(rngMonthDate.Value) > Year(Now) And Month(rngMonthDate.Value) > Month(Now) Then
        intDayOfMonth = 1
    ElseIf Year(rngMonthDate.Value) < Year(Now) And Month(rngMonthDate.Value) < Month(Now) Then
        intDayOfMonth = intDaysInMonth
    End If
    'Define the shape size
    Select Case intDayOfMonth
        Case 1:
            shp.Width = 0
        Case Else
            shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth - 1).Width
    End Select

Just tried your code, but it works same as the first code above.

 

[Martin_H]

I entered in D8 the date 1.1.2024, which should make Rectangle 1 = 0 cm width but it didn't do anything. I can still see Rectangle 1.