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

#### Martin_H

##### Board Regular
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

##### Active Member
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``````

### Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

#### Martin_H

##### Board Regular
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.

#### MartinS

##### Active Member
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.
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``````

#### Martin_H

##### Board Regular
For better understanding I am attaching two screenshots.

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

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).

#### Martin_H

##### Board Regular

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.

#### MartinS

##### Active Member

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``````

#### Martin_H

##### Board Regular
January 2021 looks like this now.

February 2021

#### MartinS

##### Active Member
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")``````

#### Martin_H

##### Board Regular
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.

Replies
2
Views
2K
Replies
0
Views
261
Replies
7
Views
445
Replies
5
Views
814
Replies
0
Views
108

1,148,426
Messages
5,746,611
Members
424,033
Latest member
al1en

### 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.

### Which adblocker are you using?

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

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