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>
 

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,716
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,716
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,081,986
Messages
5,362,561
Members
400,681
Latest member
mariscann

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top