Rearranging timetable data

bonsmara · Apr 22nd 2016

Hi,

I have a challenge with a public transport timetable (file "New Timetable" attached). In the attached file there are two tabs "Zone 3 to Pta" (this is an example of how the timetables currently look like) and "Solution" (the format in which I now need it - I only included 3 lines as example). The timetables can contain more columns as well as rows. As can be seen there are various numbers of "intermediate points with arrival times attached.

What is important (and I don't know whether it is possible) I need the name on the tab as part of the "Solution" as shown in Column A.

I need to do this for between 50 and 100 timetables of a similar format and by hand it will take days.

Is it possible to write a macro which will convert the info from the one format ("Zone 3 to Pta") to the new format as shown on "Solution"?

Your guidance and assistance will be appreciated.

Regards

Danie

Fuzz-Head · Apr 22nd 2016

Re: Rearranging timetable data

What your asking can be done in VBA reading each sheet as a object but would need a sample sheet with contained least two zone's of data to tinker with.

As far as converting time without VBA, if all your data is based on ##H## values, you can use a formula.

Example, if Cell A2 = 08H30 then the formula would be =Time(Left(A2,2),Right(A2,2),0)

Your results would be 8:30 AM

bonsmara · Apr 22nd 2016

Re: Rearranging timetable data

Hi Fuzz-Head,

Thanks for the reply. Do you mean you need a sheet with at least two tabs with timetables as attached (timetable example.xls)? You will see on the attached spreadsheet that there are a top and bottom table on the tabs which is compiled like this for easy printing. In some cases the top table is the "forward" trips and the bottom the "reverse" trips.

Just on the time issue: is it possible to do it on 24hr format in stead of adding am/pm?

Hope this will assist.

Thanks

Danie

Fuzz-Head · May 2nd 2016

Re: Rearranging timetable data

Here you go, see if this fits your needs.

You now just can add new Zones to this sheet. Use the Ref tab for any notes.. Do not add any other sheets than zones in the format from the samples you provided.

Here's the Code, Little sloppy on my part as had to finish before landing but I think it does trick.

Code

Sub Importer()




Dim ws As Worksheet
Dim sTest As String, sArea As String
Dim lRow As Long, lLaR As Long, lCol As Long, lLaC As Long
Dim lDStart As Long, lDay As Long, lDut As Long, lRou As Long, lKil As Long
Dim sDay As String, sDut As String, sRou As String, sKil As String
Dim bNum As Byte
Dim vResult() As Variant, vTemp(1 To 1, 1 To 10), vData() As Variant




ReDim vResult(1 To 15, 1 To 1)




With Sheet1
    lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        If lRow > 2 Then .Rows("3:" & lRow).Delete shift:=xlUp
End With




For Each ws In ThisWorkbook.Sheets
    
    ' Skip Results and Ref
    If ws.CodeName = "Sheet1" Or ws.CodeName = "Sheet2" Then GoTo NextOne
    
    'Run Routine
    sArea = ws.Name
        
    With ws
        lLaC = .Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column
        lLaR = .Cells(Rows.Count, 1).End(xlUp).Row
            vData = .Range("A1").Resize(lLaR + 1, lLaC)
        lRow = 1
                
ClearRowDatas:
        'clear requried row stats
            lDay = 0
            lDut = 0
            lRou = 0
            lKil = 0
            lDStart = 0
            
                'Find and Populate require row data
                For lRow = lRow To lLaR
                    'Get Days of Operation Row
                    If Trim(UCase(.Cells(lRow, 1))) = "DAYS OF OPERATION" Then
                        lDay = lRow
                        GoTo Jumper
                    End If
                    
                    'Get Shift known as Duty No.
                    If Trim(UCase(.Cells(lRow, 1))) = "DUTY NO." Then
                        lDut = lRow
                        GoTo Jumper
                    End If
                    
                    'Get Route No.
                    If Trim(UCase(.Cells(lRow, 1))) = "ROUTE NO." Then
                        lRou = lRow
                        GoTo Jumper
                    End If
                    
                    'Get Kilo
                    If Trim(UCase(.Cells(lRow, 1))) = "KILOMETRES" Then
                        lKil = lRow
                        GoTo Jumper
                    End If
                    
                    If .Cells(lRow, 1).Borders(xlEdgeBottom).LineStyle = xlDouble Then
                        lRow = lRow + 1
                        lDStart = lRow
                        lCol = 2
                        sDay = vbNullString
                        GoTo NextColumnTest
                    Else
                        GoTo Jumper
                    End If
Jumper:
                Next lRow
        If lDay * lDut * lRou * lKil * lDStart = 0 Then GoTo NextOne




NextColumnTest:
    If lCol > lLaC Then
        If lRow + 1 > lLaR Then GoTo NextOne
        GoTo ClearRowDatas
    End If
        
        sDay = vData(lDay, lCol) 'DAY OF OPERATION
            If Len(sDay) = 0 Then
                lCol = lCol + 1
                GoTo NextColumnTest
            End If
        
        bNum = 1
        lRow = lDStart
        sDut = vData(lDut, lCol) 'SHIFT NO.
        sRou = vData(lRou, lCol) 'ROUTE NO.
        sKil = vData(lKil, lCol) 'KILOMETRES
  
NextRowTest:
        
        If Len(vData(lRow, lCol)) > 0 Then
            vTemp(1, bNum) = vData(lRow, 1)
            vTemp(1, bNum + 5) = TimeSerial(Trim(Left(vData(lRow, lCol), 2)), Trim(Right(vData(lRow, lCol), 2)), 0)
                    
            bNum = bNum + 1
        End If
                    
        If Len(vData(lRow + 1, 1)) = 0 Then
            'If lRow + 5 > lLaR Then GoTo NextOne
                'Reset Row to discovery point, goto next column
                lCol = lCol + 1
                'Transfer Vtemp to Vresults
                    
                    vResult(1, UBound(vResult, 2)) = sArea 'Area
                    vResult(2, UBound(vResult, 2)) = sDay 'DAY OF OPERATION
                    vResult(3, UBound(vResult, 2)) = sDut 'SHIFT NO.
                    vResult(4, UBound(vResult, 2)) = sRou 'ROUTE NO.
                    vResult(5, UBound(vResult, 2)) = sKil 'KILOMETRES
                
                Select Case bNum - 1
                    
                    Case 2
                        
                        vResult(6, UBound(vResult, 2)) = vTemp(1, 1) 'ORIGIN
                        vResult(10, UBound(vResult, 2)) = vTemp(1, 2) 'DESTINATION
                        
                        vResult(11, UBound(vResult, 2)) = vTemp(1, 6) 'TIME DEPART
                        vResult(15, UBound(vResult, 2)) = vTemp(1, 7) 'TIME ARRIVE
                        
                    Case 3
                     
                        vResult(6, UBound(vResult, 2)) = vTemp(1, 1) 'ORIGIN
                        vResult(7, UBound(vResult, 2)) = vTemp(1, 2) 'INTERMEDIATE1
                        vResult(10, UBound(vResult, 2)) = vTemp(1, 3) 'DESTINATION
                        
                        vResult(11, UBound(vResult, 2)) = vTemp(1, 6) 'TIME DEPART
                        vResult(12, UBound(vResult, 2)) = vTemp(1, 7) 'TIME INTERMEDIATE1
                        vResult(15, UBound(vResult, 2)) = vTemp(1, 8) 'TIME ARRIVE
                    Case 4
                        
                        vResult(6, UBound(vResult, 2)) = vTemp(1, 1) 'ORIGIN
                        vResult(7, UBound(vResult, 2)) = vTemp(1, 2) 'INTERMEDIATE1
                        vResult(8, UBound(vResult, 2)) = vTemp(1, 3) 'INTERMEDIATE2
                        vResult(10, UBound(vResult, 2)) = vTemp(1, 4) 'DESTINATION
                        
                        vResult(11, UBound(vResult, 2)) = vTemp(1, 6) 'TIME DEPART
                        vResult(12, UBound(vResult, 2)) = vTemp(1, 7) 'TIME INTERMEDIATE1
                        vResult(13, UBound(vResult, 2)) = vTemp(1, 8) 'TIME INTERMEDIATE2
                        vResult(15, UBound(vResult, 2)) = vTemp(1, 9) 'TIME ARRIVE
                    Case 5
                        
                        vResult(6, UBound(vResult, 2)) = vTemp(1, 1) 'ORIGIN
                        vResult(7, UBound(vResult, 2)) = vTemp(1, 2) 'INTERMEDIATE1
                        vResult(8, UBound(vResult, 2)) = vTemp(1, 3) 'INTERMEDIATE2
                        vResult(9, UBound(vResult, 2)) = vTemp(1, 4) 'INTERMEDIATE3
                        vResult(10, UBound(vResult, 2)) = vTemp(1, 5) 'DESTINATION
                        
                        vResult(11, UBound(vResult, 2)) = vTemp(1, 6) 'TIME DEPART
                        vResult(12, UBound(vResult, 2)) = vTemp(1, 7) 'TIME INTERMEDIATE1
                        vResult(13, UBound(vResult, 2)) = vTemp(1, 8) 'TIME INTERMEDIATE2
                        vResult(14, UBound(vResult, 2)) = vTemp(1, 9) 'TIME INTERMEDIATE 3
                        vResult(15, UBound(vResult, 2)) = vTemp(1, 10) 'TIME ARRIVE
                
                End Select
                    ReDim Preserve vResult(1 To 15, 1 To UBound(vResult, 2) + 1)
                    
                bNum = 1
                GoTo NextColumnTest
        End If
        
            lRow = lRow + 1
            GoTo NextRowTest
    End With
    
NextOne:
Next ws




'Paste Results
    With Sheet1
        .Range("A3").Resize(UBound(vResult, 2), 15) = Application.WorksheetFunction.Transpose(vResult)
        'Format K thru O with Time Format
            .Range("K3").Resize(UBound(vResult, 2), 5).NumberFormat = "h:mm;@"
    End With
    
End Sub

Display More

Enjoy..

Rearranging timetable data

Participate now!

Share