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

Martin_H

Board Regular
Joined
Aug 26, 2020
Messages
190
Office Version
  1. 365
Platform
  1. Windows
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.
 
My bad
Update the code in the If/ElseIf block as follows:
VBA Code:
    'Set the variable value if the dates don't match
    If DateSerial(Year(rngMonthDate.Value), Month(rngMonthDate.Value), 1) > DateSerial(Year(Now), Month(Now), 1) Then
        intDayOfMonth = 1
    ElseIf DateSerial(Year(rngMonthDate.Value), Month(rngMonthDate.Value), 1) < DateSerial(Year(Now), Month(Now), 1) Then
        intDayOfMonth = intDaysInMonth
    End If
 
Upvote 0

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
My bad
Update the code in the If/ElseIf block as follows:
VBA Code:
    'Set the variable value if the dates don't match
    If DateSerial(Year(rngMonthDate.Value), Month(rngMonthDate.Value), 1) > DateSerial(Year(Now), Month(Now), 1) Then
        intDayOfMonth = 1
    ElseIf DateSerial(Year(rngMonthDate.Value), Month(rngMonthDate.Value), 1) < DateSerial(Year(Now), Month(Now), 1) Then
        intDayOfMonth = intDaysInMonth
    End If
Amazing, now it works, but there is one little problem.

When I enter the date 1.10.2021 in D8, Rectangle 1 should cover the range D8:AH33. Now only covers the range D8:AF33.
 
Upvote 0
When I enter the date 1.10.2021 in D8, Rectangle 1 should cover the range D8:AH33. Now only covers the range D8:AF33.
OK, again, my bad but based on your initial request:
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.
And by that logic, a month with 30 days should cover D6:AF33, and with 31 days D6:AG33, but I just noticed your comment that:
...to cover range area D6:AH33
I didn't realise you wanted the range to be fixed, seeing as it's dynamic elsewhere. That simplifies it:
VBA Code:
Dim intDayOfMonth   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")
    'Set the variable value if the dates don't match
    If DateSerial(Year(rngMonthDate.Value), Month(rngMonthDate.Value), 1) > DateSerial(Year(Now), Month(Now), 1) Then
        intDayOfMonth = 1
    ElseIf DateSerial(Year(rngMonthDate.Value), Month(rngMonthDate.Value), 1) < DateSerial(Year(Now), Month(Now), 1) Then
        intDayOfMonth = 32
    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
 
Upvote 0
For better understanding I am attaching two screenshots.

This is November 2021. Rectangle 1 is covering all the past days. (November has 30 days).
NOV.png


This is January 2021. Rectangle 1 is covering all the past days except 30.1.21 and 31.1.21. Those 2 dates should be covered by Rectangle 1 aswel. (January has 31 days).
JAN.png
 
Upvote 0
Are you sorted with the latest version of the code?
 
Upvote 0
OK, again, my bad but based on your initial request:

And by that logic, a month with 30 days should cover D6:AF33, and with 31 days D6:AG33, but I just noticed your comment that:

I didn't realise you wanted the range to be fixed, seeing as it's dynamic elsewhere. That simplifies it:
VBA Code:
Dim intDayOfMonth   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")
    'Set the variable value if the dates don't match
    If DateSerial(Year(rngMonthDate.Value), Month(rngMonthDate.Value), 1) > DateSerial(Year(Now), Month(Now), 1) Then
        intDayOfMonth = 1
    ElseIf DateSerial(Year(rngMonthDate.Value), Month(rngMonthDate.Value), 1) < DateSerial(Year(Now), Month(Now), 1) Then
        intDayOfMonth = 32
    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 it. As you can see in the screenshot below, for month February which has only 28 days, would it be possible to cover it without overflowing?

It should dynamically change based on number of days in month.

Untitsled.png
 
Upvote 0
Slightly modified version of my previous code, as you needed it as I expected:
VBA Code:
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("D3")
    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(rngMonthDate.Value) + 1, 1, 1) - 1)
    Else
        intDaysInMonth = Day(DateSerial(Year(rngMonthDate.Value), Month(rngMonthDate.Value) + 1, 1) - 1)
    End If
    'Set the variable value if the dates don't match
    If DateSerial(Year(rngMonthDate.Value), Month(rngMonthDate.Value), 1) > DateSerial(Year(Now), Month(Now), 1) Then
        intDayOfMonth = 1
    ElseIf DateSerial(Year(rngMonthDate.Value), Month(rngMonthDate.Value), 1) < DateSerial(Year(Now), Month(Now), 1) 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
 
Upvote 0
Just remove the -1 from the line:
VBA Code:
shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth - 1).Width
That covers the ranges you expect for Jan and Feb 2021, using the code sent in my last reply (except I mistakenly set the range D8 to D3 so I could see the date, so you will also need to reset:
VBA Code:
Set rngMonthDate = ActiveSheet.Range("D3")

to

Set rngMonthDate = ActiveSheet.Range("D8")
 
Upvote 0
Just remove the -1 from the line:
VBA Code:
shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth - 1).Width
That covers the ranges you expect for Jan and Feb 2021, using the code sent in my last reply (except I mistakenly set the range D8 to D3 so I could see the date, so you will also need to reset:
VBA Code:
Set rngMonthDate = ActiveSheet.Range("D3")

to

Set rngMonthDate = ActiveSheet.Range("D8")
Done.

Every month now look good except for November which look like this now.

Today's date (17.11.21) shouldn't be covered.

11.png
 
Upvote 0

Forum statistics

Threads
1,213,484
Messages
6,113,927
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top