Bus Schedule

Location: http://www.mvps.org/dmcritchie/excel/bus_sched.htm      
Home page: http://www.mvps.org/dmcritchie/excel/excel.htm
[View without Frames]

Bus Schedule with PM times as boldface

This page contains some VBA macros.  If you need assistance to install or to use a macro please refer to my  GetFormula  page.

You cannot specify boldface in regular cell formatting.  Conditional Formatting could do the boldface but that is all.  A macro is needed to change the time and formatting so that that 1:00 and 13:00 both appear as 1:00 with the PM appearing in bold, and both without AM or PM.  Example:

Original Bus Schedule Sheet
1Tour ATour A Tour BTour B
20:00Point A 5:00Point G
38:00Point B 7:00Point F
412:00Point C 12:00Point E
513:00Point D 16:00Point D
617:00Point E 17:00Point C
722:00Point F 21:00Point B
80:00Point G 5:00Point A
New Bus Schedule Sheet
1Tour ATour A Tour BTour B
20:00Point A 5:00Point G
38:00Point B 7:00Point F
412:00 Point C12:00Point E
51:00 Point D4:00Point D
65:00 Point E5:00Point C
710:00 Point F9:00Point B
80:00Point G 5:00Point A

A copy of the sheet is made.  The new sheet will have values between .5 and 1 reformatted as PM in bold.  Hours from 1 PM to midnight will have 12 hours subtracted because single digit hours are wanted.

Option Explicit
Sub Bus_Sched()
'Bus Schedule  2001-04-17  in misc
'David McRitchie  http://www.mvps.org/dmcritchie/excel/excel.htm
' show times as  0:00 1:00 12:00 1:00  with PM in bold
' uses a second sheet to accomplish this
Dim nCol As Long, nRow As Long
Dim cRow As Long
Dim lastrow As Double
Dim wsSource As Worksheet
Dim wsNew As Worksheet
Set wsSource = ActiveSheet
Dim iCell As String
Dim cell As Range
Dim oValue As Single
Sheets(ActiveSheet.Name).Copy After:=Sheets(ActiveSheet.Name)
Set wsNew = ActiveSheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'xl95 uses xlManual
For Each cell In Cells.SpecialCells(xlCellTypeConstants, 1)
   oValue = cell.Value
   iCell = cell.Address(0, 0)
   If oValue < 1 Then   'test for time less than a day
     If oValue >= 12 / 24 Then
       wsNew.Range(iCell).Font.Bold = True
       If oValue >= 13 / 24 Then oValue = oValue - 0.5
       wsNew.Range(iCell) = "'" & _
         Trim(Left(Format(oValue, "h:mm    a/p"), 5))
       wsNew.Range(iCell).HorizontalAlignment = xlRight
       wsNew.Range(iCell).NumberFormat = "h:mm"
       wsNew.Range(iCell).HorizontalAlignment = xlRight
    End If
  End If
Next cell
Application.Calculation = xlCalculationAutomatic 'xl95 uses xlAutomatic
Application.ScreenUpdating = True
End Sub
This code is also available in a separate file.


You are one of many distinguished visitors who have visited my site here or in a previous location  since this page was created on December 16, 2000.

Visit [my Excel home page]   [Index page]   [Excel Onsite Search]   [top of this page]

Please send your comments concerning this web page to: David McRitchie send email comments

Copyright © 1997 - 2004,  F. David McRitchie,  All Rights Reserved