# 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
Just deduct 1 from the initialising of intDayInMonth, i.e.
VBA Code:
``intDayOfMonth = Day(Now) - 1``

### Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

#### Martin_H

##### Board Regular
Just deduct 1 from the initialising of intDayInMonth, i.e.
VBA Code:
``intDayOfMonth = Day(Now) - 1``
Works perfectly

Much appreciated @MartinS

Thank you very much.

#### Martin_H

##### Board Regular
Just deduct 1 from the initialising of intDayInMonth, i.e.
VBA Code:
``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

VBA Code:
``shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth).Width``

#### MartinS

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

VBA Code:
``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).
VBA Code:
``````    Select Case intDayOfMonth
Case 0:
shp.Width = 0
Case Else
shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth).Width
End Select``````

#### Martin_H

##### Board Regular

In the Select Case statement, the first case should be 0, not 1 (as that is now the first day of the month).
VBA Code:
``````    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

##### Board Regular
In the Select Case statement, the first case should be 0, not 1 (as that is now the first day of the month).
VBA Code:
``````    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?

Much appreciated.

#### MartinS

##### Active Member

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

##### Well-known Member
Hi,
I have not read the whole thread but see if this code does what you want

VBA Code:
``````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

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

VBA Code:
``````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

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

VBA Code:
``````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.

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

1,148,422
Messages
5,746,589
Members
424,032
Latest member
pochie2741

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