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]

Just deduct 1 from the initialising of intDayInMonth, i.e.

intDayOfMonth = Day(Now) - 1

 

[Martin_H]

Just deduct 1 from the initialising of intDayInMonth, i.e.

intDayOfMonth = Day(Now) - 1

Works perfectly ?

Much appreciated @MartinS

Thank you very much.

 

[Martin_H]

Just deduct 1 from the initialising of intDayInMonth, i.e.

intDayOfMonth = Day(Now) - 1

Hey @MartinS today is 1st of December and I am getting "Application-defined or object-defined error" with this line highlighted

shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth).Width

 

[MartinS]

Hey @MartinS today is 1st of December and I am getting "Application-defined or object-defined error" with this line highlighted

shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth).Width

In the Select Case statement, the first case should be 0, not 1 (as that is now the first day of the month).

    Select Case intDayOfMonth
        Case 0:
            shp.Width = 0
        Case Else
            shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth).Width
    End Select

 

[Martin_H]

In the Select Case statement, the first case should be 0, not 1 (as that is now the first day of the month).

    Select Case intDayOfMonth
        Case 0:
            shp.Width = 0
        Case Else
            shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth).Width
    End Select

Thank you @MartinS.
Much appreciated

 

[Martin_H]

In the Select Case statement, the first case should be 0, not 1 (as that is now the first day of the month).

    Select Case intDayOfMonth
        Case 0:
            shp.Width = 0
        Case Else
            shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth).Width
    End Select

Well, changing the value of Case from 1 to 0 resulted into a small problem.

Let me explain this with screenshot examples for better understanding.

Screenshot_1 (see below) shows the month of October 2021. In this case, everything should be covered by the rectangle, because it is the past. Everything is fine here.

Screenshot_2 (see below) shows the month of February 2022. This is the future. In this case, nothing should be covered by the rectangle but as you can see, first day of month is covered, which is a small problem that I currently have. This problem is caused by changing the Case value from 1 to 0.

Would it be possible to fix this problem @MartinS?

Thank you for your time.
Much appreciated.

 

[MartinS]

It's not clear what the issue is as I don't know what's going into your date cell?
You stated in your specification that the width of the shape would be 0 at day one, but are you saying that rule doesn't apply for future dates?
Can you please clarify what it is you expect?

 

[dmt32]

Hi,
I have not read the whole thread but see if this code does what you want

Sub ExpandingShape()
    Dim shp                 As Shape
    Dim rng                 As Range
    Dim dDay                As Long
    Dim dDate               As Date
    Dim ThisMonth           As Boolean, PastDate As Boolean
    Dim ws                  As Worksheet

    Set ws = ActiveSheet
    
    dDate = ws.Range("D8").Value
    
    ThisMonth = CBool(Year(dDate) = Year(Date) And Month(dDate) = Month(Date))

    PastDate = CBool(Year(dDate) < Year(Date) Or Year(dDate) = Year(Date) And Month(dDate) < Month(Date))
    
    
    dDay = IIf(PastDate, Day(Application.EoMonth(dDate, 0)) + 1, IIf(ThisMonth, Day(dDate), 1))
    
    Set shp = ws.Shapes("Rectangle 1")
    If dDay > 1 Then Set rng = ws.Cells(6, 4).Resize(28, dDay - 1)
       
    If Not rng Is Nothing Then shp.Width = rng.Width Else shp.Width = 0
    
    Set shp = Nothing
    
End Sub

Code not fully tested & assumes:
- you have a way to call it
- that the required sheet is the Activesheet?

Dave

 

[Martin_H]

It's not clear what the issue is as I don't know what's going into your date cell?
You stated in your specification that the width of the shape would be 0 at day one, but are you saying that rule doesn't apply for future dates?
Can you please clarify what it is you expect?

This example shows (see the code below) how I call the month of January 2021.
I have separated buttons like the code below for each month of 2021 and 2022 (custom ribbon UI, drop down menu).

Sub JAN(control As IRibbonControl)
With Application
.ScreenUpdating = False
With Worksheets("TEST")
.Activate
.Range("C1").Value2 = "January"
.Range("C2").Value2 = "2021"
End With
.ScreenUpdating = True
End With
Call RECTANGLE_COVER
End Sub

Call RECTANGLE_COVER macro is your code @MartinS.

Inside the cell C1 is this formula: =LEFT(TEXT(EOMONTH(TODAY();0);"mmmm");3) which is showing Jan (for month of January).
Inside the cell C2 is this formula: =LEFT(TEXT(EOMONTH(TODAY();0);"yyyy");4) which is showing 2021.

Everything worked fine with the old code where Case value was 1 until 1st of December, where I got "Application-defined or object-defined error" with this line highlighted:

shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth).Width

Then I changed Case value to 0 and now, when I select any future month i.e. February 2022, first day is already covered by the rectangle, which should not be. The rectangle should only cover the past. First day of February 2022 is not the past, but the future.

 

[Martin_H]

Hi,
I have not read the whole thread but see if this code does what you want

Sub ExpandingShape()
    Dim shp                 As Shape
    Dim rng                 As Range
    Dim dDay                As Long
    Dim dDate               As Date
    Dim ThisMonth           As Boolean, PastDate As Boolean
    Dim ws                  As Worksheet

    Set ws = ActiveSheet
   
    dDate = ws.Range("D8").Value
   
    ThisMonth = CBool(Year(dDate) = Year(Date) And Month(dDate) = Month(Date))

    PastDate = CBool(Year(dDate) < Year(Date) Or Year(dDate) = Year(Date) And Month(dDate) < Month(Date))
   
   
    dDay = IIf(PastDate, Day(Application.EoMonth(dDate, 0)) + 1, IIf(ThisMonth, Day(dDate), 1))
   
    Set shp = ws.Shapes("Rectangle 1")
    If dDay > 1 Then Set rng = ws.Cells(6, 4).Resize(28, dDay - 1)
      
    If Not rng Is Nothing Then shp.Width = rng.Width Else shp.Width = 0
   
    Set shp = Nothing
   
End Sub

Code not fully tested & assumes:
- you have a way to call it
- that the required sheet is the Activesheet?

Dave

Hey @dmt32, thank you for your code.

Code works good for the past months and also for the future months.

But does not work for current month, which should look like this (see the screenshot below):

This is the current month (December 2021). Today is 3rd day of December, so 1st day and 2nd day should be covered by the rectangle because it is already the past.