Option Explicit
Sub AddTimebars()
'Could not see your image, so best guess follows from description
'Day starts at midnight (left edge of column F
'Day ends at midnight (right edge of column AC)
'Assumptions:
' In time is on/after 12:00 am of the current day
' Out Time is on/before 12:00 am the next day
' Out time is after In time
' Times are entered as hh:mm:ss, or hh:mm
'Column C Contains In time
'Column D contains Out Time
Dim shp As Shape
Dim lLastRow As Long
Dim lRowIndex As Long
Dim dteIn As Date
Dim dteOut As Date
Dim sArray As String
Dim sngTimeStartPos As Single
Dim sngTimeEndPos As Single
Dim sngDayStart As Single
Dim sngDayEnd As Single
Dim sng24HrLength As Single
Dim aryBlock As Variant
Dim sngTop As Single
Dim sngHeight As Single
Dim sngWidth As Single
Dim sngLeft As Single
Dim lBlockIndex As Long
Dim lTimeIndex As Long
Dim dteTime As String
Dim sngTimeBoxLeft As Single
Const sngTimeBoxWidth As Single = 8.25
Const sngTimeBoxHeight As Single = 6
Const sngTimeBoxTop As Single = 2
Const lOtherColor As Long = rgbTan 'Edit RGB value/Name for Other Color
Const lInToOutColor As Long = rgbLime 'Edit RGB value/Name for In to Out Color
With Worksheets("sheet1") 'Rename to sheet that holds your data
.Select
.Range("F:AC").ColumnWidth = 2.5 'Edit to change width of all hours
'Refresh First Row Time Markers
For Each shp In ActiveSheet.Shapes
If Left(shp.Name, 2) = "C_" Then shp.Delete
Next
For lTimeIndex = 0 To 24 Step 4
sngTimeBoxLeft = .Range("F1").Left - (sngTimeBoxWidth / 2) + (lTimeIndex * .Range("F1").Width)
dteTime = lTimeIndex / 24
'Time format options: "h AM/PM" for 12 hour or "hh" for 24 hour
DrawHourBox sngTimeBoxLeft, sngTimeBoxTop, sngTimeBoxWidth, sngTimeBoxHeight, Format(dteTime, "h AM/PM")
Next
sngDayStart = .Range("F1").Left
sngDayEnd = .Range("AC1").Left + .Range("AC1").Width
sng24HrLength = sngDayEnd - sngDayStart
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Counts in column A
For lRowIndex = 2 To lLastRow
dteIn = .Cells(lRowIndex, 3).Value
dteOut = .Cells(lRowIndex, 4).Value
sngTop = .Cells(lRowIndex, 3).Top + 0.1 * .Cells(lRowIndex, 3).Height
sngHeight = 0.8 * .Cells(lRowIndex, 3).Height
'Clear row of any blocks/comment from previous run
.Cells(lRowIndex, 6).Value = vbNullString
On Error Resume Next
ActiveSheet.Shapes(lRowIndex & "_BI").Delete
ActiveSheet.Shapes(lRowIndex & "_AO").Delete
ActiveSheet.Shapes(lRowIndex & "_IO").Delete
ActiveSheet.Shapes(lRowIndex & "_Group").Delete
On Error GoTo 0
'Clear loop variables
ReDim aryBlock(1 To 3): lBlockIndex = 0: sArray = vbNullString
If dteOut > dteIn And dteIn >= 0 And dteOut <= 1 Then
'add In to Out Block
sngLeft = sngDayStart + (sng24HrLength * dteIn)
sngWidth = sng24HrLength * (dteOut - dteIn)
lBlockIndex = lBlockIndex + 1
sArray = lRowIndex & "_IO"
DrawBox sngLeft, sngTop, sngWidth, sngHeight, lInToOutColor, lRowIndex & "_IO"
If dteIn > 0 Then
'Add Before In Block
sngWidth = sng24HrLength * dteIn
lBlockIndex = lBlockIndex + 1
sArray = sArray & vbLf & lRowIndex & "_BI"
DrawBox sngDayStart, sngTop, sngWidth, sngHeight, lOtherColor, lRowIndex & "_BI"
End If
If dteOut < 1 Then
'Add After Out Block
sngWidth = sng24HrLength * (1 - dteOut)
sngLeft = sngDayStart + (sng24HrLength * dteOut)
lBlockIndex = lBlockIndex + 1
sArray = sArray & vbLf & lRowIndex & "_AO"
DrawBox sngLeft, sngTop, sngWidth, sngHeight, lOtherColor, lRowIndex & "_AO"
End If
'Group
ReDim Preserve aryBlock(1 To lBlockIndex)
'sArray = Mid(sArray, 2)
'sArray = Left(sArray, Len(sArray) - 1)
ActiveSheet.Shapes.Range(Split(sArray, vbLf)).Select
Selection.ShapeRange.Group.Select
Selection.Name = lRowIndex & "_Group"
Else
With .Cells(lRowIndex, 6)
.WrapText = False
.Value = "Invalid time values"
End With
End If
Next
End With
End Sub
Function DrawBox(sngLeft, sngTop, sngWidth, sngHeight, lColor, sRowID)
ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
sngLeft, sngTop, sngWidth, sngHeight).Select
With Selection
With .ShapeRange
With .Line
.Visible = msoTrue
.Weight = 0.25
.ForeColor.RGB = lColor
.Transparency = 0
End With
With .Fill
.Visible = msoTrue
.ForeColor.RGB = lColor
.Transparency = 0
.Solid
End With
End With
.Name = sRowID
.Placement = xlFreeFloating
End With
End Function
Function DrawHourBox(sngLeft, sngTop, sngWidth, sngHeight, sText)
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, sngLeft, sngTop, sngWidth, sngHeight) _
.Select
Selection.ShapeRange.TextFrame2.MarginLeft = 0
Selection.ShapeRange.TextFrame2.MarginRight = 0
Selection.ShapeRange.TextFrame2.MarginTop = 0
Selection.ShapeRange.TextFrame2.MarginBottom = 0
With Selection.ShapeRange.TextFrame2
.VerticalAnchor = msoAnchorMiddle
.HorizontalAnchor = msoAnchorNone
End With
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
Selection.ShapeRange.Line.Visible = msoFalse
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = sText
Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
msoAlignCenter
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 7
Selection.Name = "C_" & sText
End Function
