Ho corretto il bug che risolve questo quesito e i turni verranno accodati nelle righe a seguire (sotto i collaboratori)
a meno che... (*)
- Codice: Seleziona tutto
Sub PrgTurni()
NomeF = ActiveSheet.Name
Set Ws1 = Worksheets(NomeF)
UCT = Ws1.Range("IV2").End(xlToLeft).Column
URT = Ws1.Range("A54").End(xlUp).Row
For RRT = 24 To URT
RigaC = RRT
If UCase(Mid(Ws1.Range("A" & RRT).Value, 1, 4)) <> "COLL" Or UCase(Right(Ws1.Range("A" & RRT).Value, 1)) = "X" Then Exit For
Next RRT
NC = RigaC - 23
Rep = ""
Ws1.Range("B14:O53").Interior.ColorIndex = xlNone
For RRT = 14 To 53
For CCT = 2 To UCT
If UCase(Ws1.Cells(RRT, CCT).Value) <> "NO" Then
Ws1.Cells(RRT, CCT).ClearContents
End If
Next CCT
Next RRT
For ColT = 2 To UCT
MSS = 0
Turno = "10-15"
Contaex = 0
If ColT Mod 2 = 1 Then Turno = "15-20"
For RRL = 5 To 9
Select Case RRL
Case 5
Colore = 6
Rep = "A"
Case 6
Colore = 50
Rep = "B"
Case 7
Colore = 41
Rep = "C"
Case 8
Colore = 15
Rep = "D"
Case 9
Colore = 8
Rep = "E"
End Select
NumP = Ws1.Cells(RRL, ColT).Value
For RT = 1 To NumP
If RT = 1 Then
If Ws1.Cells(RRL + 9, ColT).Value = "" Then
Ws1.Cells(RRL + 9, ColT).Value = Turno & Rep
Ws1.Cells(RRL + 9, ColT).Interior.ColorIndex = Colore
Else
Ws1.Cells(RRL + 14, ColT).Value = Turno & Rep
Ws1.Cells(RRL + 14, ColT).Interior.ColorIndex = Colore
End If
Else
MyCNo = 0
For RRC = 24 To RigaC
If UCase(Cells(RRC, ColT).Value) = "NO" Then
MyCNo = MyCNo + 1
End If
Next RRC
ST = 0
For RRT = 5 To 9
ST = ST + Cells(RRT, ColT).Value
Next RRT
If NC - MyCNo <= ST - 5 Then
RiprEx:
If NC - MyCNo < ST - 5 Then
If Contaex >= NC - MyCNo Then
AggG = "eriggio"
If Ws1.Cells(4, ColT).Value = "Matt" Then AggG = "ina"
URC = Ws1.Cells(54, ColT).End(xlUp).Row + 1 '<<<<<<<<<<<<< vedi nota
Msg = Application.Proper(Format(Ws1.Cells(3, ColT).Value, "dddd") & " " & Ws1.Cells(4, ColT).Value & AggG) & vbCrLf
Msg = Msg & "Turnisti disponibili inferiori ai turni effettivi: " & vbCrLf
Msg = Msg & "Il turno sarà accodato"
If MSS = 0 Then MsgBox Msg
MSS = 1
Ws1.Cells(URC, ColT).Value = Turno & Rep
Ws1.Cells(URC, ColT).Interior.ColorIndex = Colore
Contaex = Contaex + 1
GoTo SaltaRT
End If
End If
Rcas = Int(Rnd(NC) * NC) + 24
If Ws1.Cells(Rcas, ColT).Value <> "" Then GoTo RiprEx
Ws1.Cells(Rcas, ColT).Value = Turno & Rep
Ws1.Cells(Rcas, ColT).Interior.ColorIndex = Colore
Contaex = Contaex + 1
Else
Ripr:
Rcas = Int(Rnd(NC) * NC) + 24
MyC = Evaluate("=Min(" & NomeF & "!P24:P" & RigaC & ")")
If Ws1.Cells(Rcas, ColT).Value <> "" Then GoTo Ripr
If Ws1.Cells(Rcas, 16).Value <> MyC Then GoTo Ripr
If Turno = 2 And Ws1.Cells(Rcas, ColT - 1).Value <> "" Then GoTo Ripr
Ws1.Cells(Rcas, ColT).Value = Turno & Rep
Ws1.Cells(Rcas, ColT).Interior.ColorIndex = Colore
End If
End If
SaltaRT:
Next RT
Next RRL
Next ColT
End Sub
(*) Nota: Per avere i turni aggiunti ai responsabili, modifica la riga evindenziata con questa
- Codice: Seleziona tutto
URC = Ws1.Cells(24, ColT).End(xlUp).Row + 1
Se hai altri problemi inviami il file con impostati i turni che danno problemi
spiegando cosa ottieni con la macro e cosa vorresti ottenere
ciao
)