VBA Resize shape according to cell timevalue data-CodePudding

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

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.