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

Question

Imgur相册与工作表屏幕: http://imgur.com/a/6rFWF

长话短说，我正在编写一个Excel VBA实用程序，它将为保安人员分配两种类型的安全班次（称为coverage和weekend duties）。基本上，我有一个包含所有工作人员及其各种可用性信息的工作表（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

编辑:忽略我现在有两列的日期。一旦我解决了这个问题，我就会解决这个问题post...it这是一个简单的修复，将削减代码几乎一半。

问题是，当实用程序接近日期列表的末尾时，它经常会遇到这样的情况：唯一剩下的工作人员不能坐那个特定的轮班（无论是因为星期几还是特定的日期）。如果它遇到这种情况，我可以看到几个可接受的选项（尽管我不知道如何对它们进行编程）:

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

2. 只需停止分配班次并退出程序即可。我将能够通过移动几个人来手动放置最后几个班次。我的确比手动分配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

Answer 1

所以我前进并为这个问题开发了自己的解决方案 - 它并不完美，它可能不是处理方案的最佳方法。但它有效，它在几分钟而不是小时学习其他方法时解决了我的问题。

基本上，我创建了两个新的“计数器”变量。第一个是失败的。每次程序尝试一个随机的工作人员但运行冲突时，它会增加1.每次随机员工成功匹配（无冲突）时，它会重置为0.如果在任何时间失败= 100，则重置FaileDattempts。它立即退出循环并开始结束。换句话说，如果它在不查找匹配的情况下尝试100个随机的工作人员，我假设它不会找到匹配并削减我的损失。

第二变量，分配，每次程序都会递增1递增1。当此数字等于程序所谓的程序的变化数时，它立即退出循环。

要执行此操作，我必须使用几个禁止的'转到'命令（我不确定否则否则何时退出循环。您可以退出带有Exit的循环，但我相信这是无效的循环。我最终只需要两个goto，一个用于退出循环，一个用于返回过程的开始。我还确保在过程中改变的工作表中的单元格重置为其原始状态重试分配过程。

我会通过代码的扩展版本拯救大家阅读的麻烦，但在'伪代码'表单中它看起来像这样：

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

.

再次，可能存在（肯定是）更优雅和“正确”的方式来完成手头的任务。这种方法与给定的环境为我工作。感谢那些提供解决方案的人 - 尽管我最终进入了不同的方向，但他们为思想提供了伟大的食物，并帮助我学习了一堆新方法（特别是来自@Stenci的课堂想法）。

谢谢所有人。

Answer 2

这个问题对于详细的答案来说太开放了，所以我尝试了一些指导方针。我希望它有帮助。

我会用一个类 Solution 与以下成员:

Solution.ReadInputFromSheet() 将表从工作表中读取到类成员中

Solution.GenerateRandom() 创建一个新的随机解决方案。尝试在智能（添加一些逻辑以避免完全随机的解决方案）和速度（不要卡住，在尝试10或50个不起作用的随机数后退出）之间找到平衡点，但速度更重要

Solution.Quality() As Double 计算解决方案的质量。例如，无效的解决方案返回0，如果Joe有10个连续班次返回20，如果班次分布更好，则返回100。

Solution.WriteOnSheet() 将类成员中的数据写入工作表。

Solution.Clone() As Solution() 创建一个新的 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

而不是10000你可以使用 Timer 运行它有限的秒数，或做一个按钮，当你从午休回来中断它。

更快的解决方案生成器功能比冒险陷入一个困难（或不可能）的解决方案更好。

对于更智能的解决方案生成器功能，我需要更多关于规则的细节。