エクセルVBA:無限ループを避けるためのアドバイスを探しています
-
02-01-2020 - |
質問
ワークシートの画面を持つImgurアルバム: http://imgur.com/a/6rFWF
要するに、私はセキュリティスタッフに2種類のセキュリティシフト(カバレッジと週末の義務と呼ばれる)を割り当てる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
編集:私は今のところ2つの列に日付を持っていることを無視してください。私はこれの問題を解決したらそれを修正するでしょうpost...it'sの簡単な修正とほぼ半分にコードをカットします。
問題は、ユーティリティが日付のリストの終わりに近づくにつれて、残された唯一のスタッフがその特定のシフトに座ることができないシナリオにこのシナリオに遭遇した場合、いくつかの許容可能なオプションを見ることができます(ただし、それらをプログラミングする方法はわかりません)。:
ユーティリティが行ったすべての作業を元に戻し、幸運になって機能する解決策を見つけることができるまで最初からやり直します。これは私に最後の少数の転位のための手動配置をする時間を救うが、非常に長い時間を取るかもしれない。さらに、元の値をすべて保存してから、最初からやり直すときはいつでもスプレッドシートに貼り付ける必要があります。
単にシフトの割り当てを停止し、単に手順を終了します。私は手動で周りに数人を移動することにより、最後のいくつかのシフトを配置することができるようになります。私は確かに私は過去数年間それをやってきたように手動で手で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
解決 2
だから私は先に進んで、私自身の解決策をこの問題に対する解決策を発展させました - それは完璧ではなく、おそらくシナリオを処理するための最良の方法ではありません。しかし、それはうまくいって、他の方法を学ぶのに時間の代わりに数分の問題で私の問題を解決しました。
基本的には、2つの新しい「カウンタ」変数を作成しました。最初は失敗しました。手順がランダムなスタッフのメンバーを試みるが紛争に遭遇するたびに、それは失敗帳を1で増加させる。ランダムなスタッフのメンバーが成功した一致(衝突なし)には、失敗したものが0にリセットしました、直ちにループを出て起動します。言い換えれば、それが一致を見つけることなく行内のランダムなスタッフのメンバーを行に試みるならば、私はそれが試合を見つけ、ちょうど私の損失を削減するつもりではないと思います。
2番目の変数の割り当ては、手順が割り当てに成功した毎に1だけインクリメントされます。この数が、手順が割り当てられているシフト数に等しい場合は、直ちにループを終了します。
これを行うには、1つの禁止された 'goto'コマンドを使わなければなりませんでした(私はループを終了する方法が確実ではありませんでした。ループ。私は、ループを終了するための1つ、そして手順の始めに戻るために1つずつ2つの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からのクラスのアイデア)。
おかげでおかげでてさせます。
他のヒント
質問は詳細な答えにはあまりにも開いているので、私はいくつかのガイドラインを試してみます。私はそれが役立つことを願っています。
私はクラスを使うでしょう 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つの困難な(または不可能な)ソリューションで立ち往生する危険を冒すよりも優れています。
よりスマートなソリューションジェネレータ機能のために、私はルールの詳細が必要です。