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

Martin_H

Board Regular
Joined
Aug 26, 2020
Messages
162
Office Version
  1. 2016
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.
 

MartinS

Active Member
Joined
Jun 17, 2003
Messages
444
Office Version
  1. 365
Platform
  1. Windows
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
Joined
Aug 26, 2020
Messages
162
Office Version
  1. 2016
Platform
  1. Windows
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
Joined
Jun 17, 2003
Messages
444
Office Version
  1. 365
Platform
  1. Windows
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
Joined
Aug 26, 2020
Messages
162
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

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 (y)
 

Martin_H

Board Regular
Joined
Aug 26, 2020
Messages
162
Office Version
  1. 2016
Platform
  1. Windows
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.
1638523811460.png


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.
1638523768376.png


Would it be possible to fix this problem @MartinS?

Thank you for your time.
Much appreciated.
 

MartinS

Active Member
Joined
Jun 17, 2003
Messages
444
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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
Joined
Jul 3, 2012
Messages
6,933
Office Version
  1. 2019
Platform
  1. Windows
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
Joined
Aug 26, 2020
Messages
162
Office Version
  1. 2016
Platform
  1. Windows
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
Joined
Aug 26, 2020
Messages
162
Office Version
  1. 2016
Platform
  1. Windows
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):

1638530295893.png

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.
 

Forum statistics

Threads
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.
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
Top