带有工作表屏幕的Imgur相册：http://imgur.com/a/6rFWF
长话短说，我正在编写一个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
答案 0 :(得分：1)
这个问题太开放了，无法提供详细的答案，所以我尝试了一些指导方针。我希望它有所帮助。
我会使用以下成员的班级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运行它有限的秒数，或者当您从午休时间回来时按下按钮来中断它。
更快的解决方案生成器功能比冒着陷入一个困难（或不可能）解决方案的风险更好。
对于更智能的解决方案生成器功能，我需要有关规则的更多详细信息。
答案 1 :(得分：0)
所以我继续为这个问题开发了自己的解决方案 - 它并不完美，它可能不是处理场景的最佳方式。但它有效，它在几分钟内解决了我的问题，而不是几个小时学习其他方法。
基本上，我创建了两个新的“计数器”变量。第一个是FailedAttempts。每次程序尝试一个随机的工作人员但遇到冲突时，它会将FailedAttempts增加1.每次随机工作人员成功匹配（没有冲突）时，它会将FailedAttempts重置为0.如果在任何时候FailedAttempts = 100，它会立即退出循环并重新开始。换句话说，如果它连续尝试100个随机的工作人员而没有找到匹配，我认为它不会找到匹配并且只是减少我的损失。
每次程序成功分配时，第二个变量Assignments将加1。当此数字等于过程应该分配的班次数时，它会立即退出循环。
要做到这一点，我不得不使用一些禁止的'GoTo'命令（我不知道如何退出循环。你可以退出For循环退出For但我相信这对于Do While是无效的我最后只需要两个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的课堂理念）。
谢谢大家。