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.
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

MartinS

Active Member
Joined
Jun 17, 2003
Messages
444
Office Version
  1. 365
Platform
  1. Windows
This will do what you need, but you'll have to figure out how to trigger it - auto open event maybe?
VBA Code:
Dim intDayOfMonth   As Integer
Dim shp             As Shape
Dim rngShapeArea    As Range

    intDayOfMonth = Day(Now)-1
       
    Set rngShapeArea = ActiveSheet.Range("D6:D33")
    Set shp = ActiveSheet.Shapes("Rectangle 1")
   
    Select Case intDayOfMonth
        Case 0:
            shp.Width = intDayOfMonth
        Case Else
            shp.Width = rngShapeArea.Resize(rngShapeArea.Rows.Count, intDayOfMonth).Width
    End Select
 
Solution

KOKOSEK

Active Member
Joined
Apr 8, 2019
Messages
429
Office Version
  1. 365
  2. 2013
Platform
  1. Windows
I do not know how you want to use it, I suppose on opening the file, so put into ThisWorkbook:

VBA Code:
Private Sub Workbook_Open()
With Sheets("Sheet1")
    .Shapes("Rectangle 1").Left = [D6].Left
    .Shapes("Rectangle 1").Top = [D6].Top
    .Shapes("Rectangle 1").Height = [D6:D33].Height
    If Day(Now) > 1 Then
        .Shapes("Rectangle 1").Width = .Range(Cells(1, 4), Cells(1, 4 + (Day(Now) - 2))).Width
    Else
        .Shapes("Rectangle 1").Width = 0
    End If
End With
End Sub
 

Martin_H

Board Regular
Joined
Aug 26, 2020
Messages
162
Office Version
  1. 2016
Platform
  1. Windows
I forgot to mention that it will start automatically when the workbook is opened.

Both solutions work perfectly.

Marked first one as a solution.

Thank you @MartinS & @KOKOSEK, much appreciated (y)
 

Martin_H

Board Regular
Joined
Aug 26, 2020
Messages
162
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

One more thing.

Cell D8 is always occupied with the first day of the month, currently there is 1.11.2021.


If in cell D8 is current month & current year (e.g. November 2021) your code will work exactly as it is above.

If in cell D8 is any previous month (e.g. October, May, March or whatever) or previous year (2020, 2019, 2018 or whatever) then make Rectangle 1 to cover whole range area D6:AH33.

If in cell D8 is any following month (e.g. December) or any following year (2022, 2023 or whatever) then make Rectangle 1 = 0 cm width.


Would it be possible to make this minor change @MartinS & @KOKOSEK?

Thank you guys!
 

MartinS

Active Member
Joined
Jun 17, 2003
Messages
444
Office Version
  1. 365
Platform
  1. Windows
Sorry, not sure I understand what you are trying to do and quite how you want this changed.
If in cell D8 is any previous month
If in cell D8 is any following month
Are you saying that 01.11.2021 is an absolute fixed start date? If so, I'd suggest that is stored in VBA as a constant, then your quoted lines above will make sense, but if someone chnages D8 from 01.11.2021 to, say, 01.03.2022, how will the code know it's after 01.11?
 

Martin_H

Board Regular
Joined
Aug 26, 2020
Messages
162
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

D8 always show the first day of the current month. As I said above, D8 is now the first day of November, so 1.11.2021. D8 is formatted as a custom short date (d.m.yy)
The following month will automatically change D8 to the first day of December.
When December 2021 ends, and next year will start, D8 will be first day of January 2022 and so on.

I thought it could be somehow? done by determining from today() function.

If D8 value > today's month & year then Rectangle 1 = 0 cm width
If D8 value < today's month & year then make Rectangle 1 to cover range area D6:AH33
If D8 value = today's month & year then code above will be in charge
 

MartinS

Active Member
Joined
Jun 17, 2003
Messages
444
Office Version
  1. 365
Platform
  1. Windows
Hopefully this does what you need...

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("D8")
    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(Now) + 1, 1, 1) - 1)
    Else
        intDaysInMonth = Day(DateSerial(Year(Now), Month(Now) + 1, 1) - 1)
    End If
    'Set the variable value if the dates don't match
    If Year(rngMonthDate.Value) > Year(Now) And Month(rngMonthDate.Value) > Month(Now) Then
        intDayOfMonth = 1
    ElseIf Year(rngMonthDate.Value) < Year(Now) And Month(rngMonthDate.Value) < Month(Now) 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
Joined
Aug 26, 2020
Messages
162
Office Version
  1. 2016
Platform
  1. Windows
Hopefully this does what you need...

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("D8")
    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(Now) + 1, 1, 1) - 1)
    Else
        intDaysInMonth = Day(DateSerial(Year(Now), Month(Now) + 1, 1) - 1)
    End If
    'Set the variable value if the dates don't match
    If Year(rngMonthDate.Value) > Year(Now) And Month(rngMonthDate.Value) > Month(Now) Then
        intDayOfMonth = 1
    ElseIf Year(rngMonthDate.Value) < Year(Now) And Month(rngMonthDate.Value) < Month(Now) 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
Just tried your code, but it works same as the first code above.
 

Martin_H

Board Regular
Joined
Aug 26, 2020
Messages
162
Office Version
  1. 2016
Platform
  1. Windows
I entered in D8 the date 1.1.2024, which should make Rectangle 1 = 0 cm width but it didn't do anything. I can still see Rectangle 1.
 

Forum statistics

Threads
1,148,393
Messages
5,746,437
Members
424,018
Latest member
dionlkk6

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