Excel VBA:À procura de Conselhos para Evitar um Loop Infinito
https://stackoverflow.com//questions/25088848
-
02-01-2020 - |
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianPergunta
Imgur Album com telas de planilhas: http://imgur.com/a/6rFWF
Longa história curta, eu estou escrevendo um Excel VBA utilitário que irá atribuir dois tipos de segurança turnos (chamado de coberturas e fim-de-semana deveres) para segurança pessoal de membros.Basicamente, eu tenho uma planilha com todos os membros da equipe e suas várias informações de disponibilidade (o topo da imagem no imgur album) e uma planilha com todas as datas de cobertura (a imagem de fundo no imgur album).Nota que eu não tenho uma imagem do fim-de-semana o dever de datas como é semelhante para as datas de cobertura (mas com a sexta-feira e sábado turnos).
O utilitário basicamente atribui aleatoriamente um membro da equipe para cada data de verificação para certificar-se de não violar qualquer dos seus requisitos de disponibilidade.Infelizmente, percebo que estou criando uma grande oportunidade para um loop infinito para ocorrer.Em meus próprios testes, houve apenas 1 tentativa de cerca de 15-16 que não inserir um loop infinito perto do fim.Então, eu estou olhando para sua ajuda conta para isso, para que o utilitário não comer.
Aqui é o "pseudo-código para o procedimento em questão.
'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:Desconsidere o que eu tenho as datas em duas colunas por agora.Eu vou ser a fixação de que uma vez que eu resolver o problema deste post...é um reparo fácil e vai cortar o código quase na metade.
O problema é que, como o utilitário chega perto do fim da lista de datas, que muitas vezes corre para o cenário onde a única membros do pessoal de esquerda não pode sentar-se de que a mudança específica (se por causa do dia da semana ou data específica).No caso em que ele é executado para este cenário, eu posso ver um par de aceitável opções (apesar de eu não saber como eu iria sobre programação-los):
Desfazer todo o trabalho que o utilitário fez e recomeçar até que ele pode ter sorte e encontrar uma solução que funciona.Isso me pouparia algum tempo fazendo manual de posicionamentos para os últimos turnos, mas pode levar um tempo muito longo.Além disso, eu teria que armazenar todos os valores originais e, em seguida, colá-los de volta para a planilha sempre que ele começa.
Simplesmente parar de atribuição de turnos e só sair o procedimento.Eu vou ser capaz de colocar manualmente os últimos turnos movendo algumas pessoas à sua volta.Eu com certeza é muito menos trabalho do que atribuir manualmente 200 turnos com a mão, como eu venho fazendo isso há alguns anos.
Vocês têm alguma pensamentos que poderiam ser de ajuda aqui?Eu nem tenho certeza de como eu poderia fazer o procedimento de verificação para ver se existem quaisquer opções disponíveis ou não, mas de qualquer forma tem que haver uma maneira de detectar e impedir a) este loop infinito antes de o programa falha.
Desculpe para o romance, e agradecemos antecipadamente por qualquer ajuda!
Editar:Em um esforço para fornecer um pouco mais de clareza, eu percebi que eu copie e cole o código abaixo:
'------------------------------------------------------------'
'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
Solução 2
Então eu fui em frente e desenvolvi a minha própria solução para este problema-ele não é perfeito e provavelmente não é a melhor forma para lidar com o cenário.Mas funciona, e ele resolveu o meu problema em questão de minutos em vez de horas a aprender outros métodos.
Basicamente, eu criei duas novas "contador" de variáveis.O primeiro é FailedAttempts.Cada vez que o procedimento tenta aleatoriamente um membro da equipe, mas é executado em um conflito, ele incrementa FailedAttempts por 1.Cada vez que o aleatório membro da equipe é o sucesso de um jogo (sem conflitos), repõe FailedAttempts a 0.Se, a qualquer tempo FailedAttempts = 100, imediatamente sai do loop e começa de novo.Em outras palavras, se ele tentar 100 aleatório membros da equipe em uma linha sem encontrar uma correspondência, eu suponho que ele não vai encontrar uma correspondência e acabou de cortar minhas perdas.
A segunda variável, Atribuições, é incrementado em 1 a cada vez que o procedimento torna uma bem-sucedida missão.Quando esse número é igual ao número de turnos que o procedimento é suposto para atribuir, imediatamente sai do loop.
Para fazer isso, eu tive que usar um par de proibido 'GoTo' comandos (eu não tinha certeza de que outra forma para sair do loop.Você pode sair de um loop For com a Saída, mas acredito que este é inválido para Fazer loops While.Acabei só precisando de dois GoTo, um para sair do loop e um para ir de volta para o início do procedimento.Eu também a certeza de que as células na folha de cálculo que mudam durante o procedimento são redefinidas ao seu estado original antes de ele repete o procedimento de classificação.
Eu vou guardar todos os problemas de leitura através da versão estendida do código, mas em pseudo-código do formulário é semelhante a este:
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
Novamente, pode ser (e certamente é) um mais elegante e "corrigir" maneira de realizar a tarefa em mão.Este método funcionou para mim com o meio ambiente.Obrigado a todos aqueles que forneceram soluções, mesmo que eu acabei indo em uma direção diferente eles prestado um grande alimento para o pensamento e me ajudaram a aprender um monte de novos métodos (especialmente a classe ideia de @stenci).
Obrigado a todos.
Outras dicas
A questão é muito aberto para uma resposta detalhada, para que eu tente, com algumas orientações.Espero que ajude.
Eu gostaria de usar uma classe Solution com os seguintes membros:
Solution.ReadInputFromSheet() lê a tabela de custos para os membros da classe
Solution.GenerateRandom() cria uma nova solução aleatória.Tente encontrar um equilíbrio entre a smart (adicione um pouco de lógica para evitar totalmente aleatória de soluções) e a velocidade (não ficar preso, sair depois de tentar de 10 ou 50 números aleatórios que não funcionam), mas a velocidade é mais importante
Solution.Quality() As Double calcula a qualidade da solução.Por exemplo, uma solução que não é válido retorna 0, se o joão tem 10 turnos consecutivos retorna 20, se as mudanças são melhor distribuídas retorna 100.
Solution.WriteOnSheet() escrever os dados de todos os membros da classe para a folha.
Solution.Clone() As Solution() cria um novo Solution instância, com os mesmos dados
Fazer um ciclo que cria uma solução, verifica-se que a sua qualidade é melhor do que a melhor solução encontrada até então, se é melhor mantê-lo, caso contrário, vá e calcular outra solução.
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
Em vez de 10000 você pode usar Timer para executá-lo para um número finito de segundos, ou fazer um botão para interromper quando você voltar do almoço.
Uma solução mais rápida a função do gerador é melhor do que arriscar de ficar preso com um difícil (ou impossível) de solução.
Para um melhor solução a função do gerador de eu precisar de mais detalhes sobre as regras.
