Reformat Times

[Rishek]

Hi! Using a really helpful word macro provided by gmayor, I have extracted a bunch of data from a word document into an excel table. Now I'm looking to build an excel macro to format this data (using current versions of both programs, mac and windows as needed).

Here's the sheet ExtractedData.xlsx

I'd like to be able to first sort everything alphabetically using column A, then split the time ranges in column B into a start and end time and ideally reformat the cells as h:mm or [h]:mm.

Using the macro recorder, I have created the following monstrosity:

Sub TimeSplit2()
'
' TimeSplit2 Macro
'


'
    Cells.Select
    Range("E17").Activate
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A137") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:D137")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns("B:B").Select
    Selection.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").Select
    Selection.Delete Shift:=xlToLeft
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Start"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "End"
    Range("F2").Select


End Sub

Looking at the selection values, I'm worried that this will only work for this specific sheet (I extract this scheduling data every day and it often has a varying number of items, but it would be in this form). How would I change it so that it simply selects all the data?

I'm also not sure on how best to reformat the time into an excel-usable format. The time is in the form 10:00 – 11:00am or 10:00am – 1:00pm if the event crosses the am/pm line. Can this be done?

Thoughts?

[mdmackillop]

I see there is a Time conversion issue: 7.00 - 10.00pm is not I guess an all day event. This will change the first time if the period does not specify am and is over 12 hours. Changed cells highlighted for checking purposes

Option Explicit

Sub TimeSplit2()
    Dim ws As Worksheet
    Dim r As Range, cel As Range
    
    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


     End With
     Application.ScreenUpdating = True
End Sub

[Rishek]

Thanks! This works great, but I had to delete "Option Explicit" to get it to run. I assume some variable is intentionally undefined?

The time conversion works nicely, but how would I end up with everything in AM/PM?

And follow-up question (I fear I may have fallen victim to the the XY problem):

I'd like to be able to add up the total hours of each person in the name column in the format h:mm.

My manual solution is to use the following formula for column G: =IF(F2<E2,F2+1,F2)-E2.

Then I run column G subtotals and auto outline to be able to collapse E and F and run formatting to highlight the rows where G is greater than or equal to 6:00. This seems inelegant and the only numbers that interest me are the subtotals. Also, for events without both a start and end time it gives weird numbers.

Thoughts?

Again, thanks for the macro, it's a big step forward!

[Bob Phillips]

How about this

Option Explicit
 
Sub TimeSplit2()
    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
        With .Range("G2").Resize(lastrow - 1)
        
            .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

[mdmackillop]

Add this before the LastRow line for am/pm

r.NumberFormat = "h:mm a/p\m"

[Rishek]

Thank you! That's really excellent.

I'll be playing around with all this over the next few weeks, but that answers my immediate question! Much appreciated.

[Rishek]

Okay, so I've been playing with this and have some questions / requests:

1) How do I expand created subtotal column (G) to match the number of rows. This macro is run on sheets of variable size and I occasionally have more than 137 rows. I could, of course, just substitute "1000" for 137, since it's not likely I'll ever have more than 1000 rows, but this seems inelegant.

2) How would I expand the sorting to be first alphabetical by name and THEN chronological by start time. Easy enough with the sort function.

3) I'm trying to add a column to check if any individual has a conflict by comparing the start and end time of each commitment. Here's the formula I'd be using
" =IF($F2<>"End",IF($G2="",IF($F2>$E3,"CONFLICT",""),""),"") "

I don't know how to program this formula to automatically be inserted into column H.

[mdmackillop]

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

[Rishek]

This is going to sound a little silly, but I can't test either of the macros that take arguments. I can't get either of them to run (they don't appear in the macro menu since they take arguments and running them from the VBA Editor does nothing. Little help?

[mdmackillop]

They are both called by the TimeSplit code. They're not designed as standalone.

BTW, you'll need to make some deliberate "errors" to test.

[Rishek]

Told you I felt silly. Seems to work like a proverbial charm. I'll implement it this week and see how it does "in the wild."

Thank you.

Does excel run the entire module each time or how does this work (since I see no reference to either of the last two macros inside the first)? It seems to be different than word (also the need to fool around with the personal macro workbook and such).

[mdmackillop]

These are the calling lines

 Call HighlightErrors(ws, lastrow) 
        Call SortData(ws, lastrow)

As designed, the whole macro is run each time. If this needs changing, let us know.

[Rishek]

No, totally perfect, just didn't see 'em. Thanks.