Excel VBA：寻找避免无限循环的建议

带工作表屏幕的Imgur相册：

长话短说，我正在编写一个Excel VBA实用程序，它将为安全工作人员分配两种类型的安全轮班（称为覆盖和周末值班）。基本上，我有一个包含所有员工及其各种可用性信息的工作表（imgur相册中的顶部图像）和一个包含所有报道日期的工作表（imgur相册中的底部图像）。请注意，我没有周末值班日期的图像，因为它看起来类似于覆盖日期（但周五和周六轮班）

该实用程序基本上为每个日期分配一名随机工作人员，检查以确保其不违反任何可用性要求。不幸的是，我意识到我正在创造一个无限循环发生的大机会。在我自己的测试中，大约15-16次尝试中只有1次没有在接近终点时进入无限循环。所以我在寻找你的帮助来解释这一点，这样公用事业就不会吃自己

下面是有关过程的“伪代码”

'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

编辑：忽略我现在有两列中的日期。一旦我解决了这篇文章的问题，我将修复它…这是一个简单的修复，将代码几乎减半

问题是，当公用事业公司接近日期列表的末尾时，它经常会遇到这样的情况，即只有剩下的员工不能坐那个特定的班次（无论是因为星期几还是特定的日期）。如果遇到这种情况，我可以看到几个可接受的选项（尽管我不知道如何编程）：

撤销该实用程序所做的所有工作并重新开始，直到它幸运地找到一个可行的解决方案。这将为我节省一些时间，为最后几班做人工安置，但可能需要很长时间。此外，我必须存储所有原始值，然后在重新开始时将它们粘贴回电子表格中

只需停止分配班次，退出该程序即可。我将能够通过移动几个人来手动安排最后几班。我的工作量肯定比过去几年手动分配200个班次要少得多

你们有什么想法可以帮上忙吗？我甚至不确定如何让过程检查是否有可用的选项，但无论如何都必须有一种方法在无限循环崩溃程序之前检测（并阻止）它

对于这本小说，我深表歉意，并提前感谢您的帮助

编辑：为了更清晰一点，我想复制并粘贴下面的实际代码：

'------------------------------------------------------------'
'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

“-------------------------------------------------------------------------------------”
'为每个工作表创建ws变量
将冲突设置为工作表
将wsCoverageSlips设置为工作表
将WSWDS作为工作表进行调整
将WSCoverage输出设置为工作表
将WSWD输出设置为工作表
'------------------------------------------------------------'
公共功能设置表（）
'将工作表分配给ws变量
设置wsConflicts=工作表（“冲突”）
设置wsCoverageSlips=工作表（“保险单”）
设置wsWDSlips=工作表（“WD Slips”）
设置wsCoverageOutput=工作表（“覆盖输出”）
设置wsWDOutput=工作表（“WD输出”）
'显示消息（调试）
“MsgBox”已成功分配工作表”
端函数
'------------------------------------------------------------'
公共函数ColumnLetter（ColumnNumber为整数）为字符串
长
作为字节的Dim c
像线一样变暗
n=列数
做
c=（（n-1）模26）
s=Chr（c+65）和s
n=（n-c）\26
n>0时循环
列字母=s
端函数
'------------------------------------------------------------'
分保范围（）
'填充ws变量
调用设置表
'设置第一行和最后一行的编号
将FirstStaffMemberRow设置为整数
FirstStaffMemberRow=3
将LastStaffMemberRow设置为整数
LastStaffMemberRow=wsConflicts.UsedRange.Rows.Count
“计算所需保险和周末职责的数量
Dim RequiredCoverage为整数
作为整数的Dim RequiredWDs
对于i=FirstStaffMemberRow到LastStaffMemberRow
RequiredCoverages=RequiredCoverages+wsConflicts.Range（“B”&i）.Value
RequiredWDs=RequiredWDs+wsConflicts.Range（“C”&i）.Value
接下来我
'显示消息（调试）
MsgBox“您当前有”&RequiredCoverage&“RequiredCoverage and”&RequiredWDs&“RequiredWeekend Duty”
“计算保险单和周末值班单的数量
将FirstCoverageSlipRow设置为整数
FirstCoverageSlipRow=1
将LastCoverageSlipRow设置为整数
LastCoverageSlipRow=wsCoverageSlips.UsedRange.Rows.Count
Dim NumcOveragestips作为整数
NumCoverageSlips=（LastCoverageSlipRow-FirstCoverageSlipRow+1）
Dim FirstWDSlipRow为整数
FirstWDSlipRow=1
Dim LastWDSlipRow为整数
LastWDSlipRow=wsWDSlips.UsedRange.Rows.Count
作为整数的Dim NUMWDLIPS
numwdlips=（LastWDSlipRow-FirstWDSlipRow+1）
'检查以确保有足够的所需班次用于打滑
如果需要，则包括NumCoverageSlips
MsgBox“您需要的班次数（冲突表上的B列和C列）与您输入的单数不匹配。您有”&RequiredCoverage&“RequiredCoverage”和”&NumOverageslips&“coverage slips”。您有”&RequiredWDs&“required weekend Duty”和“&Numwdlips&”“周末值班单。请更正此错误，然后重试。“
出口接头
其他的
"调试",
“MsgBox”您需要的班次数（冲突表上的B列和C列）与您输入的单数匹配。您有“&RequiredCoverage&”所需的cove
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

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