Excel VBA:보고에 대한 조언을 피하는 무한 루프

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

02-01-2020
|

문제

진 앨범으로 화면 워크시트: http://imgur.com/a/6rFWF

Long story short,I am writing Excel VBA 유틸리티는 할당할 것이 두 가지 유형의 보안 교대(이라는 보장 범위와 주말 의무)하 보안 직원은 회원입니다.기본적으로 워크시트가 있으로 모든 직원의 구성원과 그들의 다양한 가용 정보를(위의 이미지진 앨범)그리고 워크시트의 모든 범위를 날짜에 그것은(아래 이미지에진 앨범).참고가 없어요 이미지의 의무 같은 날짜와 비슷하게 적용 날(그러나 금요일과 토요일에 변화).

유틸리티 기본적으로 할당하는 임의의 직원이 각각 날짜,을 확인하는 그를 위반하지 않는다 그들의 가용성을 요구 사항입니다.불행하게도,나는 나를 만드는 큰 기회를 위한 무한 루프가 발생할 수 있습니다.내 자신의 테스트,거기에만 1 도의 약 15-16 는 입력하지 않는 무한 루프 근처의 끝입니다.그래서 내가 찾는 당신의 도움에 대 한 계정이 유틸리티를 먹지 않는다.

여기에는"코드는"절차에 대해서 질문입니다.

'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

편집:을 무시하는 난 날짜에서 두 개의 열을 위해 지금입니다.I'll be 고치는 일단의 문제가 해결이 포스트...그것은 쉽게 수정 및 절단된 코드안에 거의 절반이다.

문제는 유틸리티를 얻 근처의 목록 끝 날짜,그것은 종종으로 실행되는 시나리오를 만 직원 왼쪽에 앉을 수 없는 특정의 변화(지기 때문에 하루의 주거나 특정 날짜).에서는 이벤트 실행으로 이 시나리오를 볼 수 있습의 몇 가지 수용 가능한 옵션(내가 알지 못하는 방법에 대해 이동 프로그램들):

취소 작업의 모든 유틸리티았다고 다시 시작할 수 있을 때까지 운이 찾는 솔루션을 작동합니다.이 시간 이렇게 수동에 대한 위치는 마지막 몇 가지 변화가 매우 오랜 시간이 걸릴.또한,나는 저장하는 모든 원래 값을 다음 다시 붙여 넣기 스프레드시트를 언제나 그것은 처음부터 다시 시작됩니다.
단순히 할당을 이동하고 종료합니다.나는 할 수 있는 수동으로소 마지막 몇 가지 변화에 의해 움직이는 몇 가지 있을 수 있습니다.나는 확실히 훨씬 적은 작업을 수동으로 할당 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

그래서 나는이 문제에 대한 내 자신의 해결책을 개발했으며, 완벽하지는 않으며, 아마도 시나리오를 처리하는 가장 좋은 방법이 아닐 것입니다. 그러나 그것은 작동하며, 다른 방법을 배우는 몇 시간 대신 몇 분 안에 문제를 해결했습니다.

기본적으로 두 개의 새로운 "카운터"변수를 만들었습니다. 첫 번째는 실패합니다. 절차가 무작위 직원을 시도하지만 충돌로 실행될 때마다 무작위 직원이 성공적인 일치 (충돌 없음) 일 때마다 실패한 직원이 0으로 재설정됩니다. 즉시 루프를 종료하고 시작합니다. 즉, 일치하는 것을 찾지 않고 100 개의 무작위 직원을 시도하면 경기를 찾지 않고 내 손실을 줄이지 않을 것이라고 가정합니다.

두 번째 변수, 할당은 절차가 성공적으로 할당 할 때마다 1만큼 증가합니다. 이 숫자가 프로 시저가 할당 해야하는 시프트 수와 같으면 즉시 루프가 종료됩니다.

이렇게하려면 몇 가지 금지 된 'goto'명령을 사용해야했습니다 (나는 루프를 종료하는 데 어떻게되는지 확신하지 못했습니다. exit로 루프를 종료 할 수는 있지만이 유효하지 않습니다. 루프. 나는 루프를 나가는 것과 절차의 시작 부분으로 돌아갈 수있는 두 개의 Goto 's 만 필요로하는 것만으로 끝났습니다. 또한 절차 중에 변경되는 워크 시트의 셀이 원래 상태로 재설정되었는지 확인했습니다. 할당 절차를 재 시도합니다.

모든 사람이 확장 된 코드 버전을 통해 읽는 데 문제를 저지하지만 '의사 코드'양식에서 다음과 같이 보입니다.

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 을 반환하는 경우,조는 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 그것을 실행에 대한 한정된 수의 초,또는 확인 버튼을 중단 할 때 당신은 그것에서 돌아와 점심 휴식입니다.

빠른 솔루션을 생성하는 함수인은 위험보다 더 갇히 하기 어려운(또는 불가능하다)솔루션입니다.

더욱 스마트한 솔루션이 생성하는 함수가 필요한 더 많은 정보에 규칙이 있습니다.

라이센스 : CC-BY-SA ~와 함께 속성

제휴하지 않습니다 StackOverflow