PDA

View Full Version : [SOLVED] Reformat Times



Rishek
05-25-2017, 06:35 AM
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 19284

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
05-25-2017, 08:50 AM
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
05-25-2017, 08:31 PM
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
05-26-2017, 04:18 AM
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
05-26-2017, 04:33 AM
Add this before the LastRow line for am/pm

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

Rishek
05-26-2017, 05:17 AM
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
05-28-2017, 08:33 PM
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
05-29-2017, 03:58 AM
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
05-29-2017, 09:17 AM
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
05-29-2017, 10:10 AM
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
05-29-2017, 10:31 AM
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
05-29-2017, 10:52 AM
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
05-29-2017, 11:01 AM
No, totally perfect, just didn't see 'em. Thanks.