Excel VBA:Ищу совет, как избежать бесконечного цикла
https://stackoverflow.com//questions/25088848
-
02-01-2020 - |
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianВопрос
Imgur Альбом со скринами рабочих листов: http://imgur.com/a/6rFWF
Короче говоря, я пишу утилиту Excel VBA, которая будет назначать сотрудникам службы безопасности два типа смен службы безопасности (называемых «работами» и «обязанности в выходные дни»).По сути, у меня есть рабочий лист со всеми сотрудниками и различной информацией о их доступности (верхнее изображение в альбоме imgur) и рабочий лист со всеми датами освещения (нижнее изображение в альбоме imgur).Обратите внимание, что у меня нет изображения дат дежурства в выходные дни, поскольку оно похоже на даты покрытия (но с учетом пятничных и субботних смен).
Утилита по сути назначает случайного сотрудника на каждую дату, проверяя, не нарушает ли это какие-либо требования к доступности.К сожалению, я понимаю, что создаю большую вероятность возникновения бесконечного цикла.В моем собственном тестировании была только одна попытка из примерно 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
Редактировать:Не обращайте внимания на то, что сейчас у меня даты в двух столбцах.Я исправлю это, как только решу проблему, описанную в этом посте... это легко исправить, и код сократится почти вдвое.
Проблема в том, что по мере того, как коммунальное предприятие приближается к концу списка дат, оно часто сталкивается со сценарием, когда единственные оставшиеся сотрудники не могут работать в эту конкретную смену (будь то из-за дня недели или конкретной даты).В случае, если он столкнется с этим сценарием, я вижу несколько приемлемых вариантов (хотя я не знаю, как бы я их запрограммировал):
Отмените всю работу, проделанную утилитой, и начните заново, пока ей не повезет и она не найдет работающее решение.Это сэкономило бы мне время на ручном размещении последних нескольких смен, но это могло бы занять очень много времени.Кроме того, мне пришлось бы сохранять все исходные значения, а затем вставлять их обратно в электронную таблицу каждый раз, когда она начинается заново.
Просто прекратите назначать смены и просто выйдите из процедуры.Я смогу вручную разместить несколько последних смен, переместив несколько человек.Я уверен, что это намного меньше работы, чем вручную назначать 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
Так что я пошел вперед и разработал свое собственное решение этой проблемы - это не идеально, и это, вероятно, не лучший способ справиться с сценарием. Но это работает, и она решила мою проблему в течение нескольких минут вместо часов, изучая другие методы.
В основном я создал два новых переменных «счетчика». Первый нестандартный поступления. Каждый раз, когда процедура пытается случайным персоналом, но запускается в конфликт, он увеличивает неудачные пошлины на 1. Каждый раз, когда случайный персонал является успешным совпадением (без конфликтов), он сбрасывает наличие посторонних посторонних пунктов. Это немедленно выходит из петли и начинается. Другими словами, если он пытается 100 случайных сотрудников в ряд, не находя в матче, я предполагаю, что он не собирается найти совпадение и просто сократить мои убытки.
Вторая переменная, назначения, приращиваются на 1 каждый раз, когда процедура делает успешное задание. Когда этот номер равняется количеству сдвигов, что процедура должна назначаться, она немедленно выходит из цикла.
Чтобы сделать это, мне пришлось использовать несколько запрещенных команд «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, если у Джо 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 чтобы запустить его на ограниченное количество секунд, или сделайте кнопку, чтобы прервать его, когда вы вернетесь с обеденного перерыва.
Более быстрая функция генератора решений лучше, чем риск застрять на одном сложном (или невозможном) решении.
Для более разумной функции генератора решений мне нужно больше подробностей о правилах.
