エクセルVBA:無限ループを避けるためのアドバイスを探しています

StackOverflow https://stackoverflow.com//questions/25088848

質問

ワークシートの画面を持つ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の簡単な修正とほぼ半分にコードをカットします。

問題は、ユーティリティが日付のリストの終わりに近づくにつれて、残された唯一のスタッフがその特定のシフトに座ることができないシナリオにこのシナリオに遭遇した場合、いくつかの許容可能なオプションを見ることができます（ただし、それらをプログラミングする方法はわかりません）。:

  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
役に立ちましたか？

解決 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つの困難な（または不可能な）ソリューションで立ち往生する危険を冒すよりも優れています。

よりスマートなソリューションジェネレータ機能のために、私はルールの詳細が必要です。

ライセンス： CC-BY-SA と 帰属
所属していません StackOverflow
scroll top