Excel VBA:Buscando consejos para evitar un bucle infinito
https://stackoverflow.com//questions/25088848
-
02-01-2020 - |
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianPregunta
Álbum Imgur con pantallas de hojas de trabajo: http://imgur.com/a/6rFWF
En pocas palabras, estoy escribiendo una utilidad VBA de Excel que asignará dos tipos de turnos de seguridad (llamados coberturas y tareas de fin de semana) a los miembros del personal de seguridad.Básicamente, tengo una hoja de trabajo con todos los miembros del personal y su información de disponibilidad (la imagen superior en el álbum de Imgur) y una hoja de trabajo con todas las fechas de cobertura (la imagen inferior en el álbum de Imgur).Tenga en cuenta que no tengo una imagen de las fechas de servicio del fin de semana, ya que parece similar a las fechas de cobertura (pero con los turnos de viernes y sábado).
Básicamente, la utilidad asigna un miembro del personal aleatorio a cada fecha, verificando que no viole ninguno de sus requisitos de disponibilidad.Desafortunadamente, me doy cuenta de que estoy creando una gran posibilidad de que se produzca un bucle infinito.En mis propias pruebas, solo hubo 1 intento de entre 15 y 16 que no entró en un bucle infinito cerca del final.Así que estoy buscando su ayuda para tener en cuenta esto para que la utilidad no se consuma a sí misma.
Aquí está el "pseudocódigo" del procedimiento en cuestión.
'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
Editar:Ojo que por ahora tengo las fechas en dos columnas.Lo arreglaré una vez que resuelva el problema de esta publicación... es una solución fácil y reducirá el código casi a la mitad.
El problema es que a medida que la empresa de servicios públicos se acerca al final de la lista de fechas, a menudo se encuentra con el escenario en el que los únicos miembros del personal que quedan no pueden cumplir ese turno específico (ya sea por el día de la semana o por una fecha específica).En caso de que se encuentre con este escenario, puedo ver un par de opciones aceptables (aunque no sé cómo programarlas):
Deshaga todo el trabajo que realizó la utilidad y comience de nuevo hasta que tenga suerte y encuentre una solución que funcione.Esto me ahorraría algo de tiempo haciendo colocaciones manuales durante los últimos turnos, pero podría llevar mucho tiempo.Además, tendría que almacenar todos los valores originales y luego volver a pegarlos en la hoja de cálculo cada vez que comience de nuevo.
Simplemente deje de asignar turnos y simplemente salga del procedimiento.Podré colocar manualmente los últimos turnos moviendo a algunas personas.Seguro que es mucho menos trabajo que asignar manualmente 200 turnos como lo he estado haciendo en los últimos años.
¿Tienen alguna idea que pueda ser de ayuda aquí?Ni siquiera estoy seguro de cómo podría hacer que el procedimiento verifique si hay opciones disponibles o no, pero de cualquier manera tiene que haber una manera de detectar (y disuadir) este bucle infinito antes de que bloquee el programa.
Perdón por la novela y gracias de antemano por cualquier ayuda.
Editar:En un esfuerzo por brindar un poco más de claridad, pensé en copiar y pegar el código real a continuación:
'------------------------------------------------------------'
'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
Solución 2
Así que seguí adelante y desarrollé mi propia solución a este problema: no es perfecto y probablemente no sea la mejor manera de manejar el escenario. Pero funciona, y resolvió mi problema en cuestión de minutos en lugar de horas aprendiendo otros métodos.
Básicamente, creé dos nuevas variables de "contador". El primero está activado. Cada vez que el procedimiento intenta un miembro del personal al azar, pero se ejecuta en un conflicto, los incrementos están activados por 1. Cada vez que el miembro del personal aleatorio es una coincidencia exitosa (sin conflictos), restablece la eliminación de detalles falciadas a 0. Si en cualquier momento se exhaustan= 100, Inmediatamente sale del bucle y se inicia. En otras palabras, si intenta 100 miembros del personal al azar en una fila sin encontrar un partido, asumo que no va a encontrar un partido y simplemente cortar mis pérdidas.
La segunda variable, las asignaciones, se incrementa en 1 cada vez que el procedimiento realiza una tarea exitosa. Cuando este número es igual a la cantidad de turnos que se supone que el procedimiento debe asignar, sale inmediatamente del bucle.
Para hacer esto, tuve que usar un par de comandos prohibidos 'goto' (no estaba seguro de de qué otra cosa salir del bucle. Puede salir de un bucle para la salida, pero creo que esto no es válido para hacerlo mientras Loops. Terminí solo necesitando dos goto's, uno para salir del bucle y otro para volver al principio del procedimiento. También me aseguré de que las células en la hoja de trabajo que cambie durante el procedimiento se restablecen a su estado original antes de ella. Reintenta el procedimiento de asignación.
AHORRARÉ A TODOS la molestia de leer a través de la versión extendida del código, pero en el formulario de 'pseudo-código' se ve así:
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
de nuevo, puede haber (y ciertamente es) una forma más elegante y "correcta" de lograr la tarea en cuestión. Este método me funcionó con el entorno dado. Gracias a aquellos que proporcionaron soluciones, aunque terminé, yendo una dirección diferente, proporcionó una excelente comida para el pensamiento y me ayudó a aprender un montón de nuevos métodos (especialmente la idea de la clase de @stenci).
gracias a todos.
Otros consejos
La pregunta es demasiado abierta para una respuesta detallada, así que intento seguir algunas pautas.Espero que ayude.
yo usaría una clase Solution con los siguientes miembros:
Solution.ReadInputFromSheet() lee la tabla de la hoja a los miembros de la clase
Solution.GenerateRandom() crea una nueva solución aleatoria.Intenta encontrar un equilibrio entre lo inteligente (añade algo de lógica para evitar soluciones totalmente aleatorias) y la velocidad (no te quedes estancado, sal después de probar 10 o 50 números aleatorios que no funcionan), pero la velocidad es más importante.
Solution.Quality() As Double Calcula la calidad de la solución.Por ejemplo una solución que no es válida devuelve 0, si Joe tiene 10 turnos consecutivos devuelve 20, si los turnos están mejor distribuidos devuelve 100.
Solution.WriteOnSheet() Escribe los datos de los miembros de la clase en la hoja.
Solution.Clone() As Solution() crea un nuevo Solution instancia con los mismos datos
Haga un ciclo que cree una solución, verifique si su calidad es mejor que la solución de mejor calidad encontrada hasta el momento, si es mejor consérvela, de lo contrario vaya y calcule otra solución.
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
En lugar de 10000 puedes usar Timer para ejecutarlo durante un número finito de segundos, o crear un botón para interrumpirlo cuando regrese de la pausa para el almuerzo.
Una función de generación de soluciones más rápida es mejor que correr el riesgo de quedarse estancado con una solución difícil (o imposible).
Para una función de generación de soluciones más inteligente, necesito más detalles sobre las reglas.
