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.stack.imgur.com/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

Just curious, will there is always one value under 1st range and 2nd range header ? Or there might be another time range under those headers ? If there is more than one time range (say there are 3 time range), then the result you want : there will be three shapes inside column D - where each height of the shape is representing the time table in column A ? Please CMIIW. — karma, Dec 21 '22 at 04:13
Exactly. Every time when I click the button it will create a shape or textbox and it will populate the top and height according to timevalue range which is 1st range and 2nd range in column A — Enrique Ferolino, Dec 21 '22 at 07:47

score 0 · Accepted Answer · answered Dec 22 '22 at 04:53

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.

Hi, this is exactly what I am looking for. It works perfectly. Thank you so much. So, by understanding of your code, and your explanation is so hard for me to understand the logic and I'm just new in VBA. — Enrique Ferolino, Dec 22 '22 at 10:04

VBA Resize shape according to cell timevalue data

1 Answers1