Notifications
Clear all

Escala semanal de trabalho com restrições

2 Posts
2 Usuários
0 Reactions
889 Visualizações
(@mineiro)
Posts: 0
Estimable Member
Topic starter
 

Olá pessoal

Preciso preencher um quadro de funcionários semanal de acordo com a disponibilidade de cada um. Criei uma "tabela de restrições" que informa quais dias o funcionário não pode ser escalado para trabalhar. Vocês poderiam me ajudar a automatizar o processo?

Segue planilha anexa com o exemplo do quadro de funcionários.

Grato.

Mineiro

 
Postado : 13/11/2015 4:24 pm
(@suggos)
Posts: 111
Estimable Member
 

Aí está minha sugestão no arquivo anexo, Mineiro.

Com essa macro, as células de J4 a J8 são utilizadas para ordenar os nomes. Por isso, o usuário não deve inserir informação nelas. Além disso, considerei que serão no máximo cinco nomes. Para uma quantidade maior, a macro deve ser adaptada.

Este é o código:

Sub Restringir()
Application.ScreenUpdating = False 'Congela a tela enquanto o código é executado e deixa a macro mais rápida
Dim i, j, resto As Byte 'Declaração de variáveis

'Cria os nomes sem acento à esquerda de cada um na tabela de restrições para possibilitar a ordenação correta destes
Range("J4:J8").FormulaLocal = "=SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(" & _
"SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(SUBSTITUIR(K4;""á"";""a"");""à"";""a"");""ã"";" & _
"""a"");""â"";""a"");""é"";""e"");""ê"";""e"");""è"";""e"");""í"";""i"");""ô"";""o"");""ó"";""o"");""õ"";""o"");""ú"";""u"")"

'Copia os nomes (sem acento) da tabela de restrições e cola na tabela amarela e cinza
Range("J4:J8").Copy
Range("D12:H21").PasteSpecial xlPasteValues

'Apaga na tabela amarela e cinza os nomes que tenham restrições e os ordena
For i = 0 To 9
resto = i Mod 2
For j = 0 To 4
If Range("L4").Offset(j, i) > 0 Then
Range("D12").Offset(j + 5 * resto, Int(i / 2)).ClearContents
End If
Next
Range("D12").Offset(5 * resto, Int(i / 2)).Select
Range(Selection, Selection.Offset(4, 0)).Sort key1:=Cells(5 * resto + 12, Int(i / 2) + 4), Header:=xlNo
Next

'Substitui os nomes sem acento por nomes com acento
For j = 0 To 4
Range("D12:H21").Replace What:=Range("J4").Offset(j, 0), Replacement:=Range("K4").Offset(j, 0)
Next

'Apaga os nomes sem acento à esquerda de cada um na tabela de restrições
Range("J4:J8").ClearContents

End Sub

Não se esqueça de marcar o tópico como resolvido se a resposta for satisfatória.

 
Postado : 14/11/2015 7:14 am