VBA Resize shape according to cell timevalue data

Question

I want to populate my shape according to time range value in 1st Range and 2nd Range cell as shown in the image. Thank you. Your help is much appreciated

https://i.sstatic.net/XNNy2.jpg

I've tried this code but it won't work.

Dim z As Range
 
 For Each z In Range("a4:a19").Rows
 If z.Value >= Range("F4") Then Exit For
 Next z

Dim x As Range
 
 For Each x In Range("a4:a19").Rows
 If x.Value >= Range("G4") Then Exit For
 
Next x
'MsgBox z & x
Dim c
Dim rnrn
c = Rows(3).Find(DateValue("12/11/2022")).Column
 'Application.InchesToPoints(10)
Dim LLL As Single, TTT As Single, WWW As Single, HHH As Single
    Set rnrn = Range(z.Address, x.Address).Offset(0, c - 1)
    LLL = rnrn.Left
    TTT = rnrn.Top
    WWW = rnrn.Width
    HHH = rnrn.Height
    With ActiveSheet.Shapes
   ' .LockAspectRatio = msoFalse
      .AddTextbox(msoTextOrientationHorizontal, LLL, TTT + Application.InchesToPoints(Range("F4").Value), WWW, Application.InchesToPoints(Range("F4").Value) + Application.InchesToPoints(Range("G4").Value)).Select
    ' .Placement = xlMove
           ' .LockAspectRatio = msoTrue
    End With
      Dim r1 As Byte, r2 As Byte, r3 As Byte
  r1 = WorksheetFunction.RandBetween(0, 255)
r2 = WorksheetFunction.RandBetween(0, 255)
r3 = WorksheetFunction.RandBetween(0, 255)
     With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(r1, r2, r3)
        .Transparency = 0
        .Solid
    End With
        Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
 With Selection.ShapeRange.TextFrame2.TextRange.Characters.ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignCenter
    End With

Selection.ShapeRange.TextFrame2.TextRange.Characters.Font.Size = 15
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = Range("F3").Text & " - " & Range("G3").Text
 

Answer 1

If I understand you correctly....

Below image is an example before running the sub

The expected result after running the sub :

If the image both is similar with your case, then maybe you want to have a look the code below then modify it according to your need. The code don't do any "fancy stuffs", such as coloring, font type, font size, etc.

Sub test()
Dim rg As Range: Dim sTxt As String: Dim eTxt As String
Dim dur: Dim pos
Dim h As Integer: Dim w As Integer
Dim L As Integer: Dim T As Integer

With ActiveSheet
For Each shp In .Shapes: shp.Delete: Next
End With

Set rg = Range("F2", Range("F" & Rows.Count).End(xlUp))

For Each cell In rg

    sTxt = Format(cell.Value, "hh:mm AM/PM")
    eTxt = Format(cell.Offset(0, 1).Value, "hh:mm AM/PM")
    dur = Format(cell.Offset(0, 1).Value - cell.Value, "h:m")
    dur = Split(dur, ":")(0) & "." & Application.RoundUp(Split(dur, ":")(1) * 1.666, 0)
    pos = Format(cell.Value, "h:m")
    pos = Split(pos, ":")(0) & "." & Application.RoundUp(Split(pos, ":")(1) * 1.666, 0)

    With Range("D4")
        h = dur * .Height: w = .Width
        L = .Left: T = .Top + ((pos - 7) * .Height)
    End With

    With ActiveSheet.Shapes
        .AddTextbox(msoTextOrientationHorizontal, L, T, w, h) _
        .TextFrame.Characters.Text = sTxt & " - " & eTxt
    End With
Next

End Sub

For the textbox size,
the height is coming from subtracting the end time with start time, split the value by ":", then add decimal point ".", then multiply the value after the decimal point with 1.666, so the approx value can be divided by 100, not 60, then multiply by the row height of row 4. The width is coming from column D width.

For the textbox position,
The top position is coming from the start time, then it s the same process like for the height of the box. The left position is coming from the left position value of column D.