Option Explicit
Sub TimeSplit3()
Dim ws As Worksheet
Dim r As Range, cel As Range, c As Range
Dim lastrow As Long
Application.ScreenUpdating = False
Set ws = ActiveSheet
With ws
Set r = Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=r.Offset(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange r.Resize(, 4)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
.Columns("B:B").TextToColumns Destination:=.Range("E1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:= _
"-", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1))
.Columns("F:F").Delete
.Range("E1:F1") = Array("Start", "End")
'Fix times
Set r = r.Offset(1, 4).Resize(, 2)
For Each cel In r.Columns(1).Cells
If Not IsNumeric(cel) And Not IsNumeric(cel.Offset(, 1)) Then
' Both text - assumed correct
cel.Value = Format(TimeValue(cel), "hh:mm")
cel.Offset(, 1).Value = Format(TimeValue(cel.Offset(, 1)), "hh:mm")
Else
For Each c In cel.Resize(, 2).Cells
If c <> "" And Not IsNumeric(c) Then c.Value = Format(TimeValue(c), "hh:mm")
Next
If Application.Count(cel.Resize(, 2)) = 2 Then
'Greater than 12 hours; add 12 hours to first time
If cel.Offset(, 1) - cel > 0.5 Then cel = cel + 0.5
'cel.Interior.ColorIndex = 6
End If
End If
Next
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Call HighlightErrors(ws, lastrow)
Call SortData(ws, lastrow)
r.NumberFormat = "h:mm a/p\m"
With .Range("G2").Resize(lastrow - 1)
.FormulaR1C1 = "=IF(RC1<>R[1]C1,SUMPRODUCT(--(R2C1:R" & lastrow & "C1=RC1),IF(R2C6:R" & lastrow & "C6="""",1,R2C6:R" & lastrow & "C6)-R2C5:R" & lastrow & "C5),"""")"
'.FormulaR1C1 = "=IF(RC1<>R[1]C1,SUMPRODUCT(--(R2C1:R137C1=RC1),IF(R2C6:R137C6="""",1,R2C6:R137C6)-R2C5:R137C5),"""")"
.NumberFormat = "hh:mm"
End With
End With
Application.ScreenUpdating = True
End Sub
Sub HighlightErrors(ws As Worksheet, lastrow As Long)
ws.Range("H2:H" & lastrow).FormulaR1C1 = _
"=IF(AND(RC[-7]=R[-1]C[-7],R[-1]C[-2]>RC[-3]),""Conflict"","""")"
With ws.Columns("F:F")
.FormatConditions.Add Type:=xlExpression, Formula1:="=AND($A2=$A1,$F1>$E2)"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
End With
With ws.Columns("E:E")
.FormatConditions.Add Type:=xlExpression, Formula1:="=AND($A1=OFFSET($A1,-1,0),$E1<OFFSET($F1,-1,0))"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
End With
Range("E1:F1").FormatConditions.Delete
End Sub
Sub SortData(ws As Worksheet, lastrow As Long)
With ws
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A2:A" & lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=Range("E2:E" & lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A1:F" & lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
End With
End Sub