Excel VBA: Looking for Advice Avoiding an Infinite Loop

Question

Imgur Album with screens of worksheets: http://imgur.com/a/6rFWF

Long story short, I am writing an Excel VBA utility that will assign two types of security shifts (called coverages and weekend duties) to security staff members. Basically, I have a worksheet with all of the staff members and their various availability information in it (the top image in the imgur album) and a worksheet with all of the coverage dates in it (the bottom image in the imgur album). Note that I don't have an image of the weekend duty dates as it looks similar to the coverage dates (but with the Friday and Saturday shifts).

The utility basically assigns a random staff member to each date, checking to make sure it doesn't violate any of their availability requirements. Unfortunately, I realize that I am creating a large chance for an infinite loop to occur. In my own testing, there has only been 1 attempt out of around 15-16 that did not enter an infinite loop near the end. So I'm looking for your help to account for this so the utility doesn't eat itself.

Here is the "pseudo-code" for the procedure in question.

'Loop for Column A in the Coverage Slips sheet (image 2 in imgur album)
Do Until (CoverageRowNumber = LastCoverageSlipRow + 1)
    Get a Random Staff Member by RNG
    If staff member still needs more shifts (see Requirements columns) Then
        If staff member does not have an "X" under the day of the week Then
            If staff member does not have a matching date conflict Then
                Assign the coverage
                Increase CoverageRowNumber
            End If
        End If
     End If
Loop

'Loop for Column B in the coverage slips sheet (image 2 in imgur album)
Do Until...

    Same as the loop above

Loop

Edit: Disregard that I have the dates in two columns for now. I'll be fixing that once I solve the problem of this post...it's an easy fix and will cut the code almost in half.

The problem is that as the utility gets near the end of the list of dates, it often runs into the scenario where the only staff members left cannot sit that specific shift (whether because of day of the week or specific date). In the event that it runs into this scenario, I can see a couple of acceptable options (though I don't know how I'd go about programming them):

1. Undo all of the work that the utility did and start over until it can get lucky and find a solution that works. This would save me some time doing manual placements for the last few shifts but might take a very long time. Additionally, I'd have to store all of the original values and then paste them back into the spreadsheet anytime it starts over.

2. Simply stop assigning shifts and just exit the procedure. I will be able to manually place the last few shifts by moving a few people around. I sure is a lot less work than manually assigning 200 shifts by hand like I've been doing it the past few years.

Do you guys have any thoughts that could be of help here? I'm not even sure how I could have the procedure check to see if there are any available options or not, but either way there's got to be a way to detect (and deter) this infinite loop before it crashes the program.

Sorry for the novel, and thanks in advance for any help!

Edit: In an effort to provide a little more clarity, I figured I'd copy and paste the actual code below:

'------------------------------------------------------------'
'Create ws variables for each worksheet
Dim wsConflicts As Worksheet
Dim wsCoverageSlips As Worksheet
Dim wsWDSlips As Worksheet
Dim wsCoverageOutput As Worksheet
Dim wsWDOutput As Worksheet

'------------------------------------------------------------'
Public Function SetSheets()
'Assign the worksheets to the ws variables
    Set wsConflicts = Worksheets("Conflicts")
    Set wsCoverageSlips = Worksheets("Coverage Slips")
    Set wsWDSlips = Worksheets("WD Slips")
    Set wsCoverageOutput = Worksheets("Coverage Output")
    Set wsWDOutput = Worksheets("WD Output")

'Display a message (debugging)
    'MsgBox "The sheets have been assigned successfully"

End Function

'------------------------------------------------------------'
Public Function ColumnLetter(ColumnNumber As Integer) As String
    Dim n As Long
    Dim c As Byte
    Dim s As String

    n = ColumnNumber
    Do
        c = ((n - 1) Mod 26)
        s = Chr(c + 65) & s
        n = (n - c) \ 26
    Loop While n > 0
    ColumnLetter = s
End Function

'------------------------------------------------------------'
Sub AssignCoverages()
'Fill the ws variables
    Call SetSheets

'Set the first and last row numbers
    Dim FirstStaffMemberRow As Integer
        FirstStaffMemberRow = 3
    Dim LastStaffMemberRow As Integer
        LastStaffMemberRow = wsConflicts.UsedRange.Rows.Count

'Count the number of required coverages and weekend duties
    Dim RequiredCoverages As Integer
    Dim RequiredWDs As Integer
    For i = FirstStaffMemberRow To LastStaffMemberRow
        RequiredCoverages = RequiredCoverages + wsConflicts.Range("B" & i).Value
        RequiredWDs = RequiredWDs + wsConflicts.Range("C" & i).Value
    Next i

'Display a message (debugging)
    MsgBox "You currently have " & RequiredCoverages & " required coverages and " & RequiredWDs & " required weekend duties."

'Count the number of coverage slips and weekend duty slips
Dim FirstCoverageSlipRow As Integer
    FirstCoverageSlipRow = 1
Dim LastCoverageSlipRow As Integer
    LastCoverageSlipRow = wsCoverageSlips.UsedRange.Rows.Count
Dim NumCoverageSlips As Integer
    NumCoverageSlips = (LastCoverageSlipRow - FirstCoverageSlipRow + 1)
Dim FirstWDSlipRow As Integer
    FirstWDSlipRow = 1
Dim LastWDSlipRow As Integer
    LastWDSlipRow = wsWDSlips.UsedRange.Rows.Count
Dim NumWDSlips As Integer
    NumWDSlips = (LastWDSlipRow - FirstWDSlipRow + 1)

'Check to make sure there are enough required shifts for slips
    If RequiredCoverages <> NumCoverageSlips Then
        MsgBox "The number of shifts you require (Columns B & C on Conflicts sheet) does not match the number of slips you've entered.  You have " & RequiredCoverages & " required coverages and " & NumCoverageSlips & " coverage slips.  You have " & RequiredWDs & " required weekend duties and " & NumWDSlips & " weekend duty slips.  Please correct this error and retry."
        Exit Sub
    Else
        'Debugging
        'MsgBox "The number of shifts you require (Columns B & C on Conflicts sheet) matches the number of slips you've entered.  You have " & RequiredCoverages & " required coverages and " & NumCoverageSlips & " coverage slips.  You have " & RequiredWDs & " required weekend duties and " & NumWDSlips & " weekend duty slips."
    End If

'Massive loop to assign coverages to random staff members
    Dim NumRemainingCoverages As Integer
        NumRemainingCoverages = NumCoverageSlips
    Dim SlipRowNumber As Integer
        SlipRowNumber = FirstCoverageSlipRow
'Loop for Column A
    Do Until (SlipRowNumber = LastCoverageSlipRow + 1)
        'Get a random staff member row
        StaffMemberRow = GetRandomStaffMemberRow(FirstStaffMemberRow, LastStaffMemberRow)

        'Check to make sure the staff member has remaining required coverages
        If wsConflicts.Range("B" & StaffMemberRow).Value > 0 Then

            'Check to make sure the staff member can sit the day of the week
                Dim CurrentDate As Date
                    CurrentDate = wsCoverageSlips.Range("A" & SlipRowNumber).Value
                Dim CurrentDay As Integer
                    CurrentDay = Weekday(CurrentDate)
                Dim CurrentDayColumn As String
                    If CurrentDay = 1 Then CurrentDayColumn = "D"
                    If CurrentDay = 2 Then CurrentDayColumn = "E"
                    If CurrentDay = 3 Then CurrentDayColumn = "F"
                    If CurrentDay = 4 Then CurrentDayColumn = "G"
                    If CurrentDay = 5 Then CurrentDayColumn = "H"
                    If CurrentDay = 6 Then CurrentDayColumn = "I"
                    If CurrentDay = 7 Then CurrentDayColumn = "J"
                If wsConflicts.Range(CurrentDayColumn & StaffMemberRow).Value = "" Then

                'Check to make sure the staff member does not have a date conflict
                    Dim ColumnNumber As Integer
                    Dim ColumnLetterText As String
                    Dim CoverageDateConflicts As Integer
                        CoverageDateConflicts = 0
                    For ColumnNumber = 11 To 20
                        ColumnLetterText = ColumnLetter(ColumnNumber)
                        Dim CoverageSlipDate As Date
                        If IsDate(wsConflicts.Range(ColumnLetterText & StaffMemberRow).Value) = True Then
                            CoverageSlipDate = wsConflicts.Range(ColumnLetterText & StaffMemberRow).Value
                        Else
                            CoverageSlipDate = DateValue("01/01/1900")
                        End If
                        If CurrentDate = CoverageSlipDate Then
                            CoverageDateConflicts = CoverageDateConflicts + 1
                        End If
                    Next ColumnNumber
                    If CoverageDateConflicts = 0 Then

                    'Assign the coverage
                        Dim BlankCoverageOutputRow As Integer
                            BlankCoverageOutputRow = wsCoverageOutput.UsedRange.Rows.Count + 1
                        wsCoverageOutput.Range("A" & BlankCoverageOutputRow).Value = wsConflicts.Range("A" & StaffMemberRow).Value
                        wsCoverageOutput.Range("B" & BlankCoverageOutputRow).Value = CurrentDate

                    'Reduce the staff member's required coverages by 1
                        Dim CurrentRequirements As Integer
                            CurrentRequirements = wsConflicts.Range("B" & StaffMemberRow).Value
                            wsConflicts.Range("B" & StaffMemberRow).Value = CurrentRequirements - 1

                    'Reduce the number of remaning coverages by 1
                        NumRemainingCoverages = NumRemainingCoverages - 1

                    'Increase the slip row number by 1
                        SlipRowNumber = SlipRowNumber + 1

                    'Message box for debugging
                        'MsgBox "Coverage Date (" & CurrentDate & ") assigned to " & wsConflicts.Range("A" & StaffMemberRow).Value & "."

                    End If 'End date check

                End If 'End day check

        End If 'End requirements check

    Loop 'End loop for column A

End Sub

'------------------------------------------------------------'
Public Function GetRandomStaffMemberRow(FirstStaffMemberRow As Integer, LastStaffMemberRow As Integer)
'Pick a random number between the first staff member row and the last
    Call Randomize
    GetRandomStaffMemberRow = Int((LastStaffMemberRow - FirstStaffMemberRow + 1) * Rnd + FirstStaffMemberRow)
End Function

Answer 1

So I went ahead and developed my own solution to this problem--it's not perfect and it's probably not the best way to handle the scenario. But it works, and it solved my problem in a matter of minutes instead of hours learning other methods.

Basically, I created two new "counter" variables. The first is FailedAttempts. Every time the procedure tries a random staff member but runs into a conflict, it increments FailedAttempts by 1. Every time the random staff member is a successful match (no conflicts), it resets FailedAttempts to 0. If at any time FailedAttempts = 100, it immediately exits the loop and starts over. In other words, if it tries 100 random staff members in a row without finding a match, I assume it's not going to find a match and just cut my losses.

The second variable, Assignments, is incremented by 1 every time that the procedure makes a successful assignment. When this number equals the number of shifts that the procedure is supposed to assign, it immediately exits the loop.

To do this, I had to use a couple of forbidden 'GoTo' commands (I wasn't sure how else to exit the loop. You can exit a For loop with Exit For but I believe this is invalid for Do While loops. I ended up only needing two GoTo's, one for exiting the loop and one to go back to the beginning of the procedure. I also made sure that the cells in the worksheet that change during the procedure are reset to their original state before it retries the assignment procedure.

I'll save everyone the trouble of reading through the extended version of the code, but in 'pseudo-code' form it looks like this:

Retry: 'Label for GoTo command

Do Until (CoverageRowNumber = LastCoverageSlipRow + 1)
    Get a Random Staff Member by RNG
    If staff member still needs more shifts (see Requirements columns) Then
        If staff member does not have an "X" under the day of the week Then
            If staff member does not have a matching date conflict Then
                'Assign the coverage
                'Increase CoverageRowNumber
                Assignments = Assignments + 1
            Else
                FailedAttempts = FailedAttempts + 1                
            End If
        Else
            FailedAttempts = FailedAttempts + 1
        End If
    Else
        FailedAttempts = FailedAttempts + 1
    End If
    If FailedAttempts > 100 Then
        GoTo ExitLoop
    End If
Loop

ExitLoop: 'Label for GoTo command
    If Assignments <> NumCoverageSlips Then
        GoTo Retry
    End If        

'Do rest of procedure

Again, there may be (and certainly is) a more elegant and "correct" way of accomplishing the task at hand. This method worked for me with the given environment. Thanks to those who provided solutions--even though I ended up going a different direction they provided great food for thought and helped me learn a bunch of new methods (especially the class idea from @stenci).

Thanks all.

Answer 2

The question is too open for a detailed answer, so I try with some guidelines. I hope it helps.

I would use a class Solution with the following members:

Solution.ReadInputFromSheet() reads the table from the sheet into the class members

Solution.GenerateRandom() creates a new random solution. Try to find a balance between smart (add some logic to avoid totally random solutions) and speed (don't get stuck, exit after trying 10 or 50 random numbers that don't work), but speed is more important

Solution.Quality() As Double calculates the quality of the solution. For example a solution that is not valid returns 0, if Joe has 10 consecutive shifts returns 20, if the shifts are better distributed returns 100.

Solution.WriteOnSheet() write the data from the class members into the sheet.

Solution.Clone() As Solution() creates a new Solution instance with the same data

Make a cycle that creates a solution, checks if its quality is better than the best quality solution found so far, if it is better keep it, otherwise go and calculate another solution.

Set BestS = New Solution
BestS.ReadInputFromSheet
BestS.GenerateRandom()

Set S = New Solution
S.ReadInputFromSheet
For I = 1 To 10000
  S.GenerateRandom()
  If S.Quality() > BestS.Quality() Then Set BestS = S.Clone()
Next I
BestS.WriteOnSheet

Instead of 10000 you can use Timer to run it for a finite number of seconds, or make a button to interrupt it when you come back from lunch break.

A faster solution generator function is better than risking of getting stuck with one difficult (or impossible) solution.

For a smarter solution generator function I need more details on the rules.