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

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

长话短说，我正在写一个Excel VBA实用程序，它将为安全人员分配两种types的安全转移（称为coverage和周末职责）。 基本上，我有一个工作表，其中包括所有工作人员及其各种可用性信息（imgur专辑中的顶部图像）以及包含所有覆盖date（imgur专辑中的底部图像）的工作表。 请注意，我没有周末工作date的图像，因为它看起来与覆盖date类似（但周五和周六class次）。

该工具基本上分配一个随机的工作人员到每个date，检查，以确保它没有违反任何可用性要求。 不幸的是，我意识到我正在创造一个发生无限循环的大机会。 在我自己的testing中，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 

编辑：无视我现在有两列的date。 一旦我解决了这个post的问题，我会解决这个问题…这是一个简单的解决方法，将代码几乎减半。

问题是，当电力公司接近date列表的末尾时，经常会遇到这样的情况，即只剩下工作人员不能坐上这个特定class次（无论是因为一周中的某一天还是特定的date）。 如果遇到这种情况，我可以看到几个可以接受的选项（尽pipe我不知道如何编程它们）：

1. 撤销该实用程序所做的所有工作，并重新开始，直到它能够幸运地find一个可行的解决scheme。 这样可以节省我一些时间在最后几个class里进行手动安排，但可能需要很长时间。 此外，我必须存储所有的原始值，然后将其粘贴回电子表格中，随时重新开始。

2. 只需停止分配class次，并退出程序。 我可以通过移动几个人来手动放置最后的几个class次。 我肯定比以前几年手动分配200个class次的工作less得多。

你们有什么想法可以帮忙吗？ 我甚至不知道如何让程序检查是否有任何可用的选项，但无论哪种方式，都必须有一种方法来检测（并阻止）这个无限循环，然后再崩溃程序。

对不起，小说，并提前感谢任何帮助！

编辑：为了提供更多的清晰度，我想我会复制并粘贴下面的实际代码：

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

这个问题太详细了，所以我尝试了一些准则。 我希望它有帮助。

我将使用以下成员的类Solution ：

Solution.ReadInputFromSheet()从表格中读取表格到类别成员中

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

Solution.Quality() As Double计算解决scheme的质量。 例如，一个无效的解决scheme返回0，如果乔有10个连续的class次返回20，如果class次更好，分配返回100。

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

Solution.Clone() As Solution()使用相同的数据创build一个新的Solution实例

创build一个解决scheme，检查其质量是否比迄今为止find的最好质量解决scheme好，如果最好保留它，否则去计算另一个解决scheme。

 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 

你可以使用Timer来运行一个有限的秒数，或者在午休时间返回时打开一个button来中断它。

更快的解决scheme生成器function要比遇到困难（或不可能）解决scheme的风险更好。

为了更智能的解决scheme生成器function，我需要更多关于规则的细节。

Answer 2

所以我继续开发自己的解决scheme来解决这个问题 – 这不是完美的，这可能不是处理这种情况的最好方法。 但是它的工作，它在几分钟内解决了我的问题，而不是几个小时学习其他方法。

基本上，我创build了两个新的“计数器”variables。 首先是FailedAttempts。 每次程序尝试一个随机的工作人员，但遇到冲突时，它会将FailedAttempts增加1.每次随机的工作人员成功匹配（无冲突）时，它将FailedAttempts重置为0.如果在任何时候FailedAttempts = 100，它立即退出循环并重新开始。 换句话说，如果连续尝试了100个随机的工作人员而没有find匹配的话，我认为它不会find一个匹配，只是减less了我的损失。

每当程序成功分配时，第二个variablesAssignments就会加1。 当这个数字等于程序应该分配的转移次数时，它立即退出循环。

要做到这一点，我不得不使用一些被禁止的'GoTo'命令（我不知道该如何退出循环，你可以用Exit For退出一个For循环，但是我相信这对Do While循环是无效的。最后只需要两个GoTo，一个用于退出循环，一个用于返回到程序的开始。我还确保在过程中更改的工作表中的单元格在重新分配之前重置为其原始状态程序。

我将通过扩展版本的代码节省每个读者的麻烦，但是在'伪代码'的forms下，它看起来像这样：

 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 

再次，可能（当然是）完成手头任务的更优雅和“正确”的方式。 这个方法在给定的环境下工作。 感谢那些提供解决scheme的人 – 尽pipe我最终走向了另一个方向，他们提供了很好的思考，并帮助我学习了一堆新的方法（特别是@stenci的类思路）。

谢谢大家。