VBA di Excel:Alla ricerca di consigli per evitare un ciclo infinito
https://stackoverflow.com//questions/25088848
-
02-01-2020 - |
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianDomanda
Imgur Album con schermate di fogli di lavoro: http://imgur.com/a/6rFWF
Per farla breve, sto scrivendo un'utilità VBA di Excel che assegnerà due tipi di turni di sicurezza (chiamati coperture e compiti del fine settimana) ai membri del personale di sicurezza.Fondamentalmente, ho un foglio di lavoro con tutti i membri dello staff e le loro varie informazioni sulla disponibilità (l'immagine in alto nell'album imgur) e un foglio di lavoro con tutte le date di copertura (l'immagine in basso nell'album imgur).Tieni presente che non ho un'immagine delle date di servizio del fine settimana poiché sembrano simili alle date di copertura (ma con i turni di venerdì e sabato).
L'utilità assegna sostanzialmente un membro dello staff casuale a ciascuna data, controllando per assicurarsi che non violi nessuno dei requisiti di disponibilità.Sfortunatamente, mi rendo conto che sto creando una grande possibilità che si verifichi un ciclo infinito.Nei miei test, c'è stato solo 1 tentativo su 15-16 che non è entrato in un ciclo infinito verso la fine.Quindi sto cercando il tuo aiuto per tenere conto di questo in modo che l'utilità non si consumi.
Ecco lo "pseudo-codice" della procedura in questione.
'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
Modificare:Non tenere conto del fatto che per ora ho le date su due colonne.Lo risolverò una volta risolto il problema di questo post... è una soluzione semplice e taglierà il codice quasi della metà.
Il problema è che quando l'utilità si avvicina alla fine dell'elenco delle date, spesso si imbatte nello scenario in cui gli unici membri dello staff rimasti non possono sedersi in quel turno specifico (a causa del giorno della settimana o di una data specifica).Nel caso in cui si verifichi questo scenario, posso vedere un paio di opzioni accettabili (anche se non so come farei per programmarle):
Annulla tutto il lavoro svolto dall'utilità e ricomincia finché non ha fortuna e trova una soluzione che funzioni.Ciò mi farebbe risparmiare un po' di tempo effettuando posizionamenti manuali per gli ultimi turni, ma potrebbe richiedere molto tempo.Inoltre, dovrei memorizzare tutti i valori originali e quindi incollarli nuovamente nel foglio di calcolo ogni volta che ricomincia.
Basta semplicemente interrompere l'assegnazione dei turni e uscire dalla procedura.Potrò posizionare manualmente gli ultimi turni spostando alcune persone.Sicuramente è molto meno lavoro che assegnare manualmente 200 turni come ho fatto negli ultimi anni.
Ragazzi, avete qualche idea che potrebbe essere d'aiuto qui?Non sono nemmeno sicuro di come controllare la procedura per vedere se ci sono opzioni disponibili o meno, ma in ogni caso deve esserci un modo per rilevare (e scoraggiare) questo ciclo infinito prima che blocchi il programma.
Ci scusiamo per il romanzo e grazie in anticipo per qualsiasi aiuto!
Modificare:Nel tentativo di fornire un po' più di chiarezza, ho pensato di copiare e incollare il codice effettivo di seguito:
'------------------------------------------------------------'
'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
Soluzione 2
Quindi sono andato avanti e ho sviluppato la mia soluzione a questo problema: non è perfetta e probabilmente non è il modo migliore per gestire lo scenario.Ma funziona e ha risolto il mio problema in pochi minuti invece che in ore imparando altri metodi.
Fondamentalmente, ho creato due nuove variabili "contatore".Il primo è FailedAttempts.Ogni volta che la procedura tenta un membro dello staff casuale ma si imbatte in un conflitto, incrementa FailedAttempts di 1.Ogni volta che il membro dello staff casuale trova una corrispondenza riuscita (senza conflitti), reimposta FailedAttempts su 0.Se in qualsiasi momento FailedAttempts = 100, esce immediatamente dal ciclo e ricomincia.In altre parole, se prova 100 membri dello staff casuali di fila senza trovare una corrispondenza, presumo che non troverà una corrispondenza e ridurrà semplicemente le mie perdite.
La seconda variabile, Assegnazioni, viene incrementata di 1 ogni volta che la procedura effettua un'assegnazione con successo.Quando questo numero equivale al numero di turni che la procedura dovrebbe assegnare, esce immediatamente dal ciclo.
Per fare ciò, ho dovuto utilizzare un paio di comandi "Vai a" proibiti (non ero sicuro di come uscire dal ciclo.Puoi uscire da un ciclo For con Exit For ma credo che questo non sia valido per i cicli Do While.Alla fine mi sono bastati due GoTo, uno per uscire dal ciclo e uno per tornare all'inizio della procedura.Mi sono anche assicurato che le celle del foglio di lavoro che cambiano durante la procedura vengano ripristinate al loro stato originale prima di ritentare la procedura di assegnazione.
Risparmiarò a tutti la fatica di leggere la versione estesa del codice, ma in forma di "pseudo-codice" assomiglia a questo:
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
Ancora una volta, potrebbe esserci (e certamente c'è) un modo più elegante e "corretto" per svolgere il compito da svolgere.Questo metodo ha funzionato per me con l'ambiente dato.Grazie a coloro che hanno fornito soluzioni: anche se alla fine ho preso una direzione diversa, mi hanno fornito ottimi spunti di riflessione e mi hanno aiutato a imparare un sacco di nuovi metodi (in particolare l'idea del corso di @stenci).
Ringrazia tutti.
Altri suggerimenti
La domanda è troppo aperta per una risposta dettagliata, quindi provo con alcune linee guida.Spero possa essere d'aiuto.
Vorrei usare una lezione Solution con i seguenti membri:
Solution.ReadInputFromSheet() legge la tabella dal foglio ai membri della classe
Solution.GenerateRandom() crea una nuova soluzione casuale.Prova a trovare un equilibrio tra intelligenza (aggiungi un po' di logica per evitare soluzioni totalmente casuali) e velocità (non rimanere bloccato, esci dopo aver provato 10 o 50 numeri casuali che non funzionano), ma la velocità è più importante
Solution.Quality() As Double calcola la qualità della soluzione.Ad esempio una soluzione non valida restituisce 0, se Joe ha 10 turni consecutivi restituisce 20, se i turni sono meglio distribuiti restituisce 100.
Solution.WriteOnSheet() scrivi i dati dei membri della classe nel foglio.
Solution.Clone() As Solution() ne crea uno nuovo Solution esempio con gli stessi dati
Fate un ciclo che crei una soluzione, controlli se la sua qualità è migliore della soluzione di miglior qualità trovata finora, se è meglio conservatela, altrimenti andate a calcolare un'altra soluzione.
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
Invece di 10000 puoi usare Timer per eseguirlo per un numero finito di secondi, oppure creare un pulsante per interromperlo quando torni dalla pausa pranzo.
Una funzione di generazione di soluzioni più veloce è meglio che rischiare di rimanere bloccati con una soluzione difficile (o impossibile).
Per una funzione di generazione di soluzioni più intelligente ho bisogno di maggiori dettagli sulle regole.
