Position and Resize Rectangles Dynamically, Based on Cell Values

[Mattman55]

I've been working on this all day and have had zero success. I want to be able to change dates in Columns A and B and have rectangles position and lengthen themselves accordingly, based on the calculated values in Columns C and D. I almost had something working earlier today but it would only change the bar length if I double-clicked inside Column D and then hit enter (i.e. it wasn't truly dynamic). I don't have any meaningful code to share because I've been chopping it all up throughout the day in various bouts of frustration.

I don't want to use conditional formatting, because the user will have the option to switch the timescale to monthly, quarterly, yearly, etc., so I'll have to handle the length calculations (Column D) separately based on that criteria. If someone can give me a seed to start with, I think I can water it until it grows into my final vision.

Thanks in advance for your time. I was trying not to bother y'all but I'm in over my head.

 

[Mattman55]

will send it right away.

Thank you!

 

[Mattman55]

I got it to work! Ultimately the code I need to position my bars (rectangles) and change their length based on cell values was;

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count = 1 Then
If Not Intersect(Target, Range("A3:H57")) Is Nothing Then
With ActiveSheet.Shapes("Rectangle 1")
.Visible = True
.Left = Range("C13").Value
.Width = Range("F13").Value
.Height = Range("A6").Value
End With
With ActiveSheet.Shapes("Rectangle 2")
.Visible = True
.Left = Range("C18").Value
.Width = Range("F18").Value
.Height = Range("A6").Value
End With
With ActiveSheet.Shapes("Rectangle 3")
.Visible = True
.Left = Range("C23").Value
.Width = Range("F23").Value
.Height = Range("A6").Value
End With
End If
End If
End Sub

Thank you vw412 for all your help!!

 

[vw412]

True, you can assume that E1 will be the date of the first day of a period. As this tool is used from project to project, some projects are short duration (months) and some span half a decade. I let the user select (M)onth, (Q)uarter, (B)iannual, or (Y)ear. From there, the timescale will reconfigure itself accordingly. I have a preliminary working version of that already set up (see screenshot).

If you have anything, even rough, to send me I'll be very grateful. I'm on a deadline to get something working this week. Thanks again!

View attachment 37225

As an addition to this OP after the fact, since the period references are dependent on this formula I made a User Defined Function to simplify and expand it. UDF was placed in a standard module (I named it modUDFs) and is:

Public Function PeriodDate(Mode As Long, RefCell As Range) As Date
  Select Case Mode
    Case 1 'Monthly
      PeriodDate = DateSerial(Year(RefCell.Value), Month(RefCell.Value) + 1, Day(RefCell.Value))
    Case 2 'Quarterly
      PeriodDate = DateSerial(Year(RefCell.Value), Month(RefCell.Value) + 3, Day(RefCell.Value))
    Case 3  'Biannually
      PeriodDate = DateSerial(Year(RefCell.Value), Month(RefCell.Value) + 6, Day(RefCell.Value))
    Case 4  'Yearly
      PeriodDate = DateSerial(Year(RefCell.Value) + 1, Month(RefCell.Value), Day(RefCell.Value))
    Case 5  'Daily
      PeriodDate = DateSerial(Year(RefCell.Value), Month(RefCell.Value), Day(RefCell.Value) + 1)
  End Select 'Mode
End Function

The reworked formula is:

=IF(OR(K$10=0,K$10=""),"",IF(AND(K$10<$M$7,PeriodDate($F$3,K$10)<=$M$7),PeriodDate($F$3,K$10),IF(AND(K$10<$M$7,PeriodDate($F$3,K$10)>=$M$7),"",PeriodDate($F$3,K$10))))

and should be in every cell that could possibly be needed for period headers.

I also changed the Listbox used for the period selection for Monthly, Quarterly, etc. to a ComboBox for one primary reason: A ComboBox will generate a Change event that can be used to trigger some actions. The ComboBox_Change event code is in the Worksheet code module and is:

Private Sub ComboBox1_Change()
  'assume Shapes are already configured
  Call GetShapes
  ActiveSheet.Range("F3") = ComboBox1.ListIndex + 1
  Call ResetShapes
End Sub

This will call the GetShapes routine to populate a Collection with all the shapes on the worksheet to facilitate manipulating them. Then it put the value of the ComboBox into cell F3. And finally it runs ResetShapes to change all the shapes relative to the selected period.

GetShapes is in a standard module as such:

Option Explicit
Public CrntShapes As Collection

Public Sub GetShapes()
  Dim ws As Object, shp As Object
  ' clear all ProgressBar shapes
  If CrntShapes Is Nothing Then  'Or CrntShapes.Count = 0 Then
    Set CrntShapes = New Collection
    For Each ws In ThisWorkbook.Worksheets
      For Each shp In ws.Shapes
        CrntShapes.Add shp
      Next shp
    Next ws
  End If
End Sub

Note the Public CrntShapes as Collection is a global variable so is available to all routines in this workbook.

The rest of the code is as follows and is all in the worksheet code module:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Count = 1 Then
    If Not Intersect(Target, Range("A3:B57")) Is Nothing Then
    ElseIf Not Intersect(Target, Range("M4:M7")) Is Nothing Then 'update shapes if user changed project dates
      Call ResetShapes
    'elseif Not intersect(Target, Range() is nothing then  'add other ranges to capture user changes
    End If
  End If
End Sub

Private Sub ResetShapes()
  Dim PeriodWidth As Single, PeriodLeft As Single, PeriodDays As Long, ProjectTotalDays As Long
  Dim StartDisplayPeriodDate As Date, EndDisplayPeriodDate As Date
  Dim shp As Object, PointsPerDay As Single, i As Long, j As Long
  StartDisplayPeriodDate = Cells(10, 11).Value
  PeriodLeft = Cells(10, 11).Left ' absolute left position of period
  EndDisplayPeriodDate = LastPeriodDate
  PeriodWidth = CalcPeriodSize ' full width of columns for start-end period
  PeriodDays = LastPeriodDate - StartDisplayPeriodDate + 1 ' inclusive number of days in PeriodWidth
  PointsPerDay = PeriodWidth / PeriodDays ' how many screen points per day
  ProjectTotalDays = Cells(7, 13) - Cells(4, 13) + 1 ' inclusive days
  For Each shp In CrntShapes
    Select Case Left(shp.Name, 6)
      Case "Rectan"
        shp.Left = PeriodLeft + (Cells(4, 13) - StartDisplayPeriodDate) * PointsPerDay 'PeriodLeft + (startday - periodstart)*PPD
        shp.Width = ProjectTotalDays * PointsPerDay
      Case "Diamon"
        'figure which row to get symbol date
        i = CLng(Right(shp.Name, 2)) - 1
        j = i * 5
        shp.Left = PeriodLeft + (Cells(13 + j, 6) - StartDisplayPeriodDate + 1) * PointsPerDay 'PeriodLeft + (startday - periodstart)*PPD
      Case "Isosce"
        'figure which row to get symbol date
        i = CLng(Right(shp.Name, 2)) - 1
        j = i * 5
        shp.Left = PeriodLeft + (Cells(13 + j, 7) - StartDisplayPeriodDate + 1) * PointsPerDay 'PeriodLeft + (startday - periodstart)*PPD
    End Select
  Next shp
End Sub
Private Function CalcPeriodSize() As Single
  Dim i As Long
  i = 11 ' start column is K
  Do Until Cells(10, i).Value = "" Or Cells(10, i).Value = 0 'look for first 0 or blank cell in period row 10
    i = i + 1
  Loop
  CalcPeriodSize = (Cells(10, i - 1).Left + Cells(10, i - 1).Width) - Cells(10, 11).Left
End Function
Private Function LastPeriodDate() As Date
  Dim i As Long
  i = 11 ' start column is K
  Do Until Cells(10, i).Value = "" Or Cells(10, i).Value = 0
    i = i + 1
  Loop
  Select Case Cells(3, 6).Value
    Case 1
      LastPeriodDate = DateSerial(Year(Cells(10, i - 1).Value), Month(Cells(10, i - 1).Value) + 1, 0)
    Case 2
      LastPeriodDate = DateSerial(Year(Cells(10, i - 1).Value), Month(Cells(10, i - 1).Value) + 3, 0)
    Case 3
      LastPeriodDate = DateSerial(Year(Cells(10, i - 1).Value), Month(Cells(10, i - 1).Value) + 6, 0)
    Case 4
      LastPeriodDate = DateSerial(Year(Cells(10, i - 1).Value) + 1, Month(Cells(10, i - 1).Value) + 1, 0)
    Case 5
      LastPeriodDate = DateSerial(Year(Cells(10, i - 1).Value), Month(Cells(10, i - 1).Value), Day(Cells(10, i - 1).Value))
  End Select 'Mode
End Function

I am sure it could be a bit cleaner and I am not happy with variable names (not very descriptive) but it illustrates event procedures, working with collections, translating date ranges to size values for the shapes. Also shows what one can do by understanding the Excel Object Model a little.