Excel - Getting a Roster to highlight/identify gaps in a 24/7 roster

DavidGa

New Member
Joined
Jun 26, 2019
Messages
1
I have looked through some of the other questions on here and can't seem to find the answer so hope someone can help me, there is probably a simple fix to my issue and I am showing my limited knowledge regarding the functionality of excel.

I have a 24/7 roster that I would like to automatically show any gaps, currently this is done manually and is a painstaking task. An example of what a week would look like is below. The lines with the word SPARE can be ignored. Would there be a formula I could use to show the gaps between shifts in the bottom line? For example I can see that there is a 1545 to 2230 gap on the Sunday, but I currently would manually enter this.

w/c 22/09/2019SundayMondayTuesdayWednesdayThursdayFridaySaturday
STARTFINISHSTARTFINISHSTARTFINISHSTARTFINISHSTARTFINISHSTARTFINISHSTARTFINISH
NAME07:0015:4507:0015:4507:0015:4507:0015:45
22:3007:1522:3007:1522:3007:1522:3007:15
SPARESPARESPARESPARE
07:0015:4507:0015:4507:0015:4507:0015:4507:0015:45
22:3007:1522:3007:1522:3007:1522:3007:15
14:0022:4514:0022:4514:0022:4514:0022:45
07:3013:1507:3013:1511:1517:45OFF
17:3022:4517:3022:4510:0015:30
GAPS:

<tbody>
</tbody>
 

Some videos you may like

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,768
This code worked on your test data. If it fails on other data, please post that data.
Put this code in a standard module in the workbook that contains your data.

Code:
Option Explicit

Sub FindGaps()
    'https://www.mrexcel.com/forum/excel-questions/1102242-excel-getting-roster-highlight-identify-gaps-24-7-roster.html
    'Assume that all times are on or below row 3 and above the row containing 'Gaps'
    'Assume the day starts at 0700; 0700 corresponds to minute 0, 0659 the next day corresponds to minute 1440
    
    Dim lGapsRow As Long
    Dim lDayIndex As Long
    Dim lMinuteIndex As Long
    Dim ofound As Object
    Dim dteTimeStart As Date
    Dim dteTimeEnd As Date
    Dim lRowIndex As Long
    Dim lGapIndex As Long
    Dim aryGaps() As Variant
    Dim lPrevious As Long
    Dim lOutputRow As Long
    
    Const dteDayStart As Date = 7 / 24
    
    Dim oSD As Object
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
    Dim rngCell As Range
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
    
    Set ofound = Columns("A:A").Find(What:="gaps", LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    If Not ofound Is Nothing Then
        lGapsRow = ofound.Row
    Else
        MsgBox "No 'GAPS' row.  Add 'GAPS' in column below the last time line"
        GoTo End_Sub
    End If
    
    'Iterate each day
    For lDayIndex = 2 To 14 Step 2
        Set oSD = CreateObject("Scripting.Dictionary")
        oSD.CompareMode = vbTextCompare
        'Populate Scripting Dictionary
        For lMinuteIndex = 1 To 1440: oSD.Item(lMinuteIndex) = oSD.Item(lMinuteIndex) + 1: Next
        For lRowIndex = 3 To lGapsRow - 1
            If IsNumeric(Cells(lRowIndex, lDayIndex).Value) And Len(Cells(lRowIndex, lDayIndex).Value) > 0 Then
                dteTimeStart = Cells(lRowIndex, lDayIndex).Value - dteDayStart
                dteTimeEnd = Cells(lRowIndex, lDayIndex + 1).Value - dteDayStart
                If dteTimeEnd < dteTimeStart Then dteTimeEnd = 1
                For lMinuteIndex = 1440 * dteTimeStart To 1440 * dteTimeEnd
                    If oSD.exists(lMinuteIndex) Then oSD.Remove lMinuteIndex
                Next
            End If
        Next
        'Check for gaps
        If oSD.Count > 0 Then
            'some minutes not covered
            varK = oSD.keys
            lPrevious = -5: lGapIndex = 0
            For lMinuteIndex = 0 To oSD.Count - 1
                If varK(lMinuteIndex) <> lPrevious + 1 Then
                    lGapIndex = lGapIndex + 1
                    ReDim Preserve aryGaps(1 To 2, 1 To lGapIndex)
                    aryGaps(1, lGapIndex) = varK(lMinuteIndex)
                    If lGapIndex > 1 Then
                         aryGaps(2, lGapIndex - 1) = varK(lMinuteIndex - 1)
                    End If
                End If
                lPrevious = varK(lMinuteIndex)
                'Stop
                
            Next
            aryGaps(2, lGapIndex) = varK(lMinuteIndex - 1)
            
            lOutputRow = lGapsRow
            For lGapIndex = LBound(aryGaps, 2) To UBound(aryGaps, 2)
                With Cells(lGapsRow, lDayIndex)
                    If .MergeArea.Cells.Count > 1 Then .MergeCells = False
                    .Value = (aryGaps(1, lGapIndex) / 1440) + dteDayStart
                    .NumberFormat = "hh:mm"
                End With
                With Cells(lGapsRow, lDayIndex + 1)
                    If .MergeArea.Cells.Count > 1 Then .MergeCells = False
                    .Value = (aryGaps(2, lGapIndex) / 1440) + dteDayStart
                    .NumberFormat = "hh:mm"
                End With
                lGapsRow = lGapsRow + 1
            Next
        End If
    Next
End_Sub:
        
End Sub
 

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,768
Correcting output alignment issues and making the gap times match the beginning and ending of the working times rather than the minute before or after the working times.

Code:
Option Explicit

Sub FindGaps()
    'https://www.mrexcel.com/forum/excel-questions/1102242-excel-getting-roster-highlight-identify-gaps-24-7-roster.html
    'Assume that all times are on or below row 3 and above the row containing 'Gaps'
    'Assume the day starts at 0700; 0700 corresponds to minute 0, 0700 the next day corresponds to minute 1440
    
    Dim lGapsRow As Long
    Dim lDayIndex As Long
    Dim lMinuteIndex As Long
    Dim ofound As Object
    Dim dteTimeStart As Date
    Dim dteTimeEnd As Date
    Dim lRowIndex As Long
    Dim lGapIndex As Long
    Dim aryGaps() As Variant
    Dim lPrevious As Long
    Dim lOutputRow As Long
    Dim lMaxOutputRow As Long
    
    Const dteDayStart As Date = 7 / 24
    
    Dim oSD As Object
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
    Dim rngCell As Range
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
    
    Set ofound = Columns("A:A").Find(What:="gaps", LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    If Not ofound Is Nothing Then
        lGapsRow = ofound.Row
    Else
        MsgBox "No 'GAPS' row.  Add 'GAPS' in column A below the last time line"
        GoTo End_Sub
    End If
    
    'Iterate each day
    For lDayIndex = 2 To 14 Step 2
        Set oSD = CreateObject("Scripting.Dictionary")
        oSD.CompareMode = vbTextCompare
        'Populate Scripting Dictionary
        For lMinuteIndex = 0 To 1440: oSD.Item(lMinuteIndex) = oSD.Item(lMinuteIndex) + 1: Next
        For lRowIndex = 3 To lGapsRow - 1
            If IsNumeric(Cells(lRowIndex, lDayIndex).Value) And Len(Cells(lRowIndex, lDayIndex).Value) > 0 Then
                dteTimeStart = Cells(lRowIndex, lDayIndex).Value - dteDayStart
                dteTimeEnd = Cells(lRowIndex, lDayIndex + 1).Value - dteDayStart
                If dteTimeEnd < dteTimeStart Then dteTimeEnd = 1 + dteTimeEnd
                For lMinuteIndex = 1440 * dteTimeStart To 1440 * dteTimeEnd
                    If oSD.exists(lMinuteIndex) Then oSD.Remove lMinuteIndex
                Next
            End If
        Next
        'Check for gaps
        If oSD.Count > 0 Then
            'some minutes not covered
            varK = oSD.keys
            lPrevious = -5: lGapIndex = 0
            For lMinuteIndex = 0 To oSD.Count - 1
                If varK(lMinuteIndex) <> lPrevious + 1 Then
                    lGapIndex = lGapIndex + 1
                    ReDim Preserve aryGaps(1 To 2, 1 To lGapIndex)
                    aryGaps(1, lGapIndex) = varK(lMinuteIndex) - 1
                    If lGapIndex > 1 Then
                         aryGaps(2, lGapIndex - 1) = varK(lMinuteIndex - 1) + 1
                    End If
                End If
                lPrevious = varK(lMinuteIndex)
                'Stop
                
            Next
            aryGaps(2, lGapIndex) = varK(lMinuteIndex - 1) + 1
            If aryGaps(2, lGapIndex) > dteDayStart Then aryGaps(2, lGapIndex) = dteDayStart
            
            lOutputRow = lGapsRow
            For lGapIndex = LBound(aryGaps, 2) To UBound(aryGaps, 2)
                With Cells(lOutputRow, lDayIndex)
                    If .MergeArea.Cells.Count > 1 Then .MergeCells = False
                    .Value = (aryGaps(1, lGapIndex) / 1440) + dteDayStart
                    .NumberFormat = "hh:mm"
                End With
                With Cells(lOutputRow, lDayIndex + 1)
                    If .MergeArea.Cells.Count > 1 Then .MergeCells = False
                    .Value = (aryGaps(2, lGapIndex) / 1440) + dteDayStart
                    .NumberFormat = "hh:mm"
                End With
                lOutputRow = lOutputRow + 1
            Next
        End If
        If lOutputRow > lMaxOutputRow Then lMaxOutputRow = lOutputRow
    Next
    
    'Formatting
    With Range(Range("B3"), Cells(lMaxOutputRow, 15))
        .NumberFormat = "hh:mm"
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    With Range(Range("A1"), Cells(lMaxOutputRow, 15))
        With .Font
            .Name = "Tahoma"
            .Size = 10
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .ThemeFont = xlThemeFontNone
        End With
    End With
    
    Range("A1:O2").HorizontalAlignment = xlCenter

End_Sub:
        
End Sub
 
Last edited:

Forum statistics

Threads
1,089,227
Messages
5,406,991
Members
403,116
Latest member
HKLeung

This Week's Hot Topics

Top