ExcelVBA :À la recherche de conseils pour éviter une boucle infinie
https://stackoverflow.com//questions/25088848
-
02-01-2020 - |
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianQuestion
Imgur Album avec des écrans de feuilles de calcul : http://imgur.com/a/6rFWF
Pour faire court, j'écris un utilitaire Excel VBA qui attribuera deux types d'équipes de sécurité (appelées couvertures et tâches de week-end) aux membres du personnel de sécurité.Fondamentalement, j'ai une feuille de travail avec tous les membres du personnel et leurs diverses informations de disponibilité (l'image du haut dans l'album imgur) et une feuille de travail avec toutes les dates de couverture (l'image du bas dans l'album imgur).Notez que je n'ai pas d'image des dates de service du week-end car elles ressemblent aux dates de couverture (mais avec les équipes du vendredi et du samedi).
L'utilitaire attribue essentiellement un membre du personnel aléatoire à chaque date, vérifiant que cela ne viole aucune de leurs exigences de disponibilité.Malheureusement, je me rends compte que je crée une grande chance qu'une boucle infinie se produise.Lors de mes propres tests, il n'y a eu qu'une seule tentative sur environ 15-16 qui n'est pas entrée dans une boucle infinie vers la fin.Je recherche donc votre aide pour en tenir compte afin que l'utilitaire ne se mange pas tout seul.
Voici le "pseudo-code" de la procédure en question.
'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
Modifier:Ne tenez pas compte du fait que j'ai les dates sur deux colonnes pour l'instant.Je vais résoudre ce problème une fois que j'aurai résolu le problème de cet article... c'est une solution simple et réduira le code presque de moitié.
Le problème est que, à mesure que le service public approche de la fin de la liste des dates, il se retrouve souvent dans un scénario dans lequel les seuls membres du personnel restants ne peuvent pas assurer ce quart de travail spécifique (que ce soit en raison du jour de la semaine ou d'une date spécifique).Dans le cas où cela se produirait dans ce scénario, je peux voir quelques options acceptables (même si je ne sais pas comment je procéderais pour les programmer) :
Annulez tout le travail effectué par l'utilitaire et recommencez jusqu'à ce qu'il ait de la chance et trouve une solution qui fonctionne.Cela me ferait gagner du temps lors des placements manuels pour les dernières équipes, mais cela pourrait prendre beaucoup de temps.De plus, je devrais stocker toutes les valeurs d'origine, puis les recoller dans la feuille de calcul à chaque fois qu'elle recommence.
Arrêtez simplement d'attribuer des équipes et quittez simplement la procédure.Je pourrai placer manuellement les derniers quarts de travail en déplaçant quelques personnes.Je suis sûr que cela représente beaucoup moins de travail que d'attribuer manuellement 200 équipes comme je l'ai fait ces dernières années.
Avez-vous des idées qui pourraient être utiles ici ?Je ne sais même pas comment je pourrais faire vérifier la procédure pour voir s'il existe des options disponibles ou non, mais dans tous les cas, il doit y avoir un moyen de détecter (et de dissuader) cette boucle infinie avant qu'elle ne plante le programme.
Désolé pour le roman et merci d'avance pour toute aide !
Modifier:Dans un effort pour fournir un peu plus de clarté, j'ai pensé copier et coller le code ci-dessous :
'------------------------------------------------------------'
'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
La solution 2
Alors je suis allé de l'avant et j'ai développé ma propre solution à ce problème - ce n'est pas parfait et ce n'est probablement pas le meilleur moyen de gérer le scénario. Mais cela fonctionne et cela résolva mon problème en quelques minutes au lieu d'heures d'apprentissage d'autres méthodes.
Fondamentalement, j'ai créé deux nouvelles variables "comptoir". Le premier est échoué. Chaque fois que la procédure essaie un membre du personnel aléatoire mais s'inscrit dans un conflit, il incrémente la battamate de 1. Chaque fois que le membre du personnel aléatoire est un match réussi (pas de conflits), il réinitialise la défaillance de 0. Si, à tout moment, échoué= 100, Il quitte immédiatement la boucle et commence. En d'autres termes, s'il essaie 100 membres du personnel aléatoire de suite sans trouver de match, je suppose que cela ne va pas trouver un match et simplement couper mes pertes.
La deuxième variable, les affectations, sont incrémentées de 1 chaque fois que la procédure effectue une mission réussie. Lorsque ce numéro est égal au nombre de décalages que la procédure est censée attribuer, il quitte immédiatement la boucle.
Pour ce faire, je devais utiliser quelques commandes interdites 'goto' (je n'étais pas sûre de la sortie de la boucle. Vous pouvez quitter une boucle avec sortie, mais je crois que cela n'est pas valide pour faire boucles. J'ai fini par avoir besoin de deux goto, un pour quitter la boucle et une pour revenir au début de la procédure. Je m'assurai aussi que les cellules de la feuille de calcul qui changent au cours de la procédure sont réinitialisées à leur état d'origine avant de pouvoir Réessaie la procédure d'affectation.
Je vais enregistrer tout le monde la peine de lire à travers la version étendue du code, mais dans la forme 'pseudo-code', on ressemble à ceci:
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
Encore une fois, il peut y avoir (et est certainement) un moyen plus élégant et "correct" d'accomplir la tâche à accomplir. Cette méthode a fonctionné pour moi avec l'environnement donné. Grâce à ceux qui ont fourni des solutions - même si j'ai fini par passer une direction différente, ils ont fourni une grande nourriture à la pensée et m'ont aidé à apprendre un groupe de nouvelles méthodes (en particulier l'idée de classe de @stenci).
Merci tout.
Autres conseils
La question est trop ouverte pour une réponse détaillée, j'essaie donc avec quelques lignes directrices.J'espère que ça aide.
j'utiliserais un cours Solution avec les membres suivants :
Solution.ReadInputFromSheet() lit le tableau de la feuille aux élèves de la classe
Solution.GenerateRandom() crée une nouvelle solution aléatoire.Essayez de trouver un équilibre entre l'intelligence (ajoutez un peu de logique pour éviter les solutions totalement aléatoires) et la vitesse (ne restez pas bloqué, sortez après avoir essayé 10 ou 50 nombres aléatoires qui ne fonctionnent pas), mais la vitesse est plus importante
Solution.Quality() As Double calcule la qualité de la solution.Par exemple, une solution qui n'est pas valide renvoie 0, si Joe a 10 équipes consécutives renvoie 20, si les équipes sont mieux réparties renvoie 100.
Solution.WriteOnSheet() écrivez les données des membres de la classe sur la feuille.
Solution.Clone() As Solution() crée un nouveau Solution instance avec les mêmes données
Faites un cycle qui crée une solution, vérifie si sa qualité est meilleure que la solution de meilleure qualité trouvée jusqu'à présent, s'il vaut mieux la conserver, sinon allez calculer une autre 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
Au lieu de 10 000, vous pouvez utiliser Timer pour l'exécuter pendant un nombre fini de secondes, ou faire un bouton pour l'interrompre lorsque vous revenez de la pause déjeuner.
Il vaut mieux disposer d’une fonction de générateur de solutions plus rapide que de risquer de se retrouver coincé avec une solution difficile (voire impossible).
Pour une fonction de générateur de solutions plus intelligente, j'ai besoin de plus de détails sur les règles.
