ciao robi1112, hai gia' ricevuto una risposta da Anthony47, ti posto anche la mia...
il codice che ho preparato esegue l'assegnazione dei colori su questi criteri:
- non piu' di una M verde al giorno,
- non piu' di una P verde al giorno,
- non piu' di una P gialla al giorno,
- non piu' di una M gialla al giorno.
- assega il colore al nominativo che ha ricevuto il numero di assegnazioni piu' basse fno a quel momento,
- se per una particolare distribuzione dei turni non si potesse rendere possibile l'assegnazione mediante criterio sopracitato, esegue una compensazione (nel listato sono le sub nominate rettifica).
Per poter mettere il programma in condizione di funzionare al meglio occorre tener libere le aree:
- E43:AJ46
- AL8:AQ42
in quanto servono al programma per poter tenere conto delle assegnazioni fatte su giorno e su nominativo.
Inoltre e' opportuno non lasciare nessuna riga vuota e inserire i nominativi con i relativi turni a partire sempre dalla riga 11.
Per quanto riguarda invece l'esecuzione pratica del programma devi fare copia e incolla del listato all'interno del vba e lanciare SOLO la sub chiamata "MainFlow".
a disposizione per chiarimenti o implementazioni, spero di esserti stato utile
- Codice: Seleziona tutto
Sub MainFlow()
Call ResettaContatoriDeiGiorni
Call ImpostacontatoreCumulativoGiorni
Call ImpostaContatoriUtente
Call ResettaColoriInTabella
10
Cells(44, 36) = Cells(43, 36)
Call ColoraCella2
If Cells(44, 36) <> Cells(43, 36) Then GoTo 10
Call RettificaAssegnazioneMgialle
Call RettificaAssegnazioneMverdi
Call RettificaAssegnazionePgialle
Call RettificaAssegnazionePverdi
Call CancellaAreeDiCalcolo
MsgBox "Processo terminato"
End Sub
Sub ColoraCella2()
'individua l'area da trattare
UltimaRigaOccupata = ActiveSheet.Cells(65536, 2).End(xlUp).Row
UltimaColonnaOccupata = ActiveSheet.Cells(11, 256).End(xlToLeft).Column - 8
colonna = 5
For riga = 11 To UltimaRigaOccupata
'====================================================================================
' ASSEGNAZIONE M VERDI color 43
'====================================================================================
10
If colonna > UltimaColonnaOccupata Then
colonna = 5
GoTo 20
End If
If Cells(10, colonna) = 1 Then
Cells(43, colonna) = 0
Cells(44, colonna) = 0
Cells(45, colonna) = 0
Cells(46, colonna) = 0
colonna = colonna + 1
GoTo 10
End If
If Cells(43, colonna) <> 1 Then 'se nel giorno e' gia' stata assegnata una M verde
colonna = colonna + 1
GoTo 10 'passa alla colonna successiva
End If
Cells(riga, colonna).Select 'seleziona la cella da valutare
If ActiveCell = "M" Then 'se la cella selezionata e' M
'controllo se l'utente in esame ha un numero di assegnazioni di M verdi maggiori degli altri utenti
'se si passo oltre altrimenti procedo con l'assegnazione
If Cells(riga, 38) = Cells(8, 38) Then
If Selection.Interior.ColorIndex = 2 Then 'se la cella e' bianca
Selection.Interior.ColorIndex = 43 'la coloro di verde
Cells(riga, 38) = Cells(riga, 38) + 1 'aggiorno il contatore utente
Cells(43, colonna) = Cells(43, colonna) - 1 'aggiorno il contatore giornata
colonna = colonna + 1 'avanzo di una colonna
GoTo 10
Else
colonna = colonna + 1 'altrimenti avanzo di una colonna e
GoTo 10 'rifaccio il cilo della M verde
End If
Else
colonna = colonna + 1
GoTo 10
End If
Else
colonna = colonna + 1
GoTo 10
End If
'====================================================================================
' ASSEGNAZIONE M GIALLE color 6
'====================================================================================
20
If colonna > UltimaColonnaOccupata Then
colonna = 5
GoTo 30
End If
If Cells(10, colonna) = 1 Then
colonna = colonna + 1
GoTo 20
End If
If Cells(44, colonna) <> 1 Then
colonna = colonna + 1
GoTo 20
End If
Cells(riga, colonna).Select
If ActiveCell = "M" Then
If Cells(riga, 39) = Cells(8, 39) Then
If Selection.Interior.ColorIndex = 2 Then
Selection.Interior.ColorIndex = 6
Cells(riga, 39) = Cells(riga, 39) + 1
Cells(44, colonna) = Cells(44, colonna) - 1
colonna = colonna + 1
GoTo 20
Else
colonna = colonna + 1
GoTo 20
End If
Else
colonna = colonna + 1
GoTo 20
End If
Else
colonna = colonna + 1
GoTo 20
End If
'====================================================================================
' ASSEGNAZIONE M BIANCHE
'====================================================================================
30
If colonna > UltimaColonnaOccupata Then
colonna = 5
GoTo 40
End If
If Cells(10, colonna) = 1 Then
colonna = colonna + 1
GoTo 30
End If
Cells(riga, colonna).Select
If ActiveCell = "M" Then
If Cells(riga, 42) = Cells(8, 42) Then
If Selection.Interior.ColorIndex = 2 Then
Cells(riga, 42) = Cells(riga, 42) + 1
colonna = colonna + 1
GoTo 30
Else
colonna = colonna + 1
GoTo 30
End If
Else
colonna = colonna + 1
GoTo 30
End If
Else
colonna = colonna + 1
GoTo 30
End If
40
50
'====================================================================================
' ASSEGNAZIONE P BIANCHE
'====================================================================================
60
If colonna > UltimaColonnaOccupata Then
colonna = 5
GoTo 70
End If
If Cells(10, colonna) = 1 Then
colonna = colonna + 1
GoTo 60
End If
Cells(riga, colonna).Select
If ActiveCell = "P" Then
If Cells(riga, 43) = Cells(8, 43) Then
If Selection.Interior.ColorIndex = 2 Then
Cells(riga, 43) = Cells(riga, 43) + 1
colonna = colonna + 1
GoTo 60
Else
colonna = colonna + 1
GoTo 60
End If
Else
colonna = colonna + 1
GoTo 60
End If
Else
colonna = colonna + 1
GoTo 60
End If
'====================================================================================
' ASSEGNAZIONE P VERDE
'====================================================================================
70
If colonna > UltimaColonnaOccupata Then
colonna = 5
GoTo 80
End If
If Cells(10, colonna) = 1 Then
colonna = colonna + 1
GoTo 70
End If
If Cells(45, colonna) <> 1 Then
colonna = colonna + 1
GoTo 70 '
End If
Cells(riga, colonna).Select
If ActiveCell = "P" Then
If Cells(riga, 40) = Cells(8, 40) Then
If Selection.Interior.ColorIndex = 2 Then
Selection.Interior.ColorIndex = 43
Cells(riga, 40) = Cells(riga, 40) + 1
Cells(45, colonna) = Cells(45, colonna) - 1
colonna = colonna + 1
GoTo 70
Else
colonna = colonna + 1
GoTo 70
End If
Else
colonna = colonna + 1
GoTo 70
End If
Else
colonna = colonna + 1
GoTo 70
End If
80
' 'assegno una P giallo
If colonna > UltimaColonnaOccupata Then
colonna = 5
GoTo 90
End If
If Cells(10, colonna) = 1 Then
colonna = colonna + 1
GoTo 80
End If
If Cells(46, colonna) <> 1 Then
colonna = colonna + 1
GoTo 80
End If
Cells(riga, colonna).Select
If ActiveCell = "P" Then
If Cells(riga, 41) = Cells(8, 41) Then
If Selection.Interior.ColorIndex = 2 Then
Selection.Interior.ColorIndex = 6
Cells(riga, 41) = Cells(riga, 41) + 1
Cells(46, colonna) = Cells(46, colonna) - 1
colonna = colonna + 1
GoTo 80
Else
colonna = colonna + 1
GoTo 80
End If
Else
colonna = colonna + 1
GoTo 80
End If
Else
colonna = colonna + 1
GoTo 80
End If
90
colonna = colonna - 1
100
Next riga
End Sub
Sub RettificaAssegnazionePgialle()
'=============================================================
' controllo su p gialle mancanti
'=============================================================
UltimaColonnaOccupata = ActiveSheet.Cells(46, 256).End(xlToLeft).Column
For x = 5 To UltimaColonnaOccupata
If Cells(46, x) <> 0 Then
Cells(46, x).Select
RigaDiPartenza = ActiveCell.Row
10
Cells(RigaDiPartenza, x).Select
If Cells(RigaDiPartenza, x) = "P" And Cells(RigaDiPartenza, x).Interior.ColorIndex = 2 Then
Cells(RigaDiPartenza, x).Interior.ColorIndex = 6
Cells(RigaDiPartenza, 41) = Cells(RigaDiPartenza, 41) + 1
Cells(46, x) = Cells(46, x) - 1
Else
RigaDiPartenza = RigaDiPartenza - 1
GoTo 10
End If
End If
Next x
End Sub
Sub RettificaAssegnazionePverdi()
'=============================================================
' controllo su p verdi mancanti
'=============================================================
UltimaColonnaOccupata = ActiveSheet.Cells(45, 256).End(xlToLeft).Column
For x = 5 To UltimaColonnaOccupata
Cells(45, x).Select
If Cells(45, x) <> 0 Then
Cells(45, x).Select
RigaDiPartenza = ActiveCell.Row
10
Cells(RigaDiPartenza, x).Select
If Cells(RigaDiPartenza, x) = "P" And Cells(RigaDiPartenza, x).Interior.ColorIndex = 2 Then
Cells(RigaDiPartenza, x).Interior.ColorIndex = 43
Cells(RigaDiPartenza, 40) = Cells(RigaDiPartenza, 40) + 1
Cells(45, x) = Cells(45, x) - 1
Else
RigaDiPartenza = RigaDiPartenza - 1
GoTo 10
End If
End If
Next x
End Sub
Sub RettificaAssegnazioneMgialle()
'controllo su m gialle mancanti
UltimaColonnaOccupata = ActiveSheet.Cells(44, 256).End(xlToLeft).Column - 1
For x = 5 To UltimaColonnaOccupata
Cells(44, x).Select
If Cells(44, x) <> 0 Then
Cells(44, x).Select
RigaDiPartenza = ActiveCell.Row
10
Cells(RigaDiPartenza, x).Select
If Cells(RigaDiPartenza, x) = "M" And Cells(RigaDiPartenza, x).Interior.ColorIndex = 2 Then
Cells(RigaDiPartenza, x).Interior.ColorIndex = 6
Cells(RigaDiPartenza, 39) = Cells(RigaDiPartenza, 39) + 1
Cells(44, x) = Cells(44, x) - 1
Else
RigaDiPartenza = RigaDiPartenza - 1
GoTo 10
End If
End If
Next x
End Sub
Sub RettificaAssegnazioneMverdi()
'controllo su m verdi mancanti
UltimaColonnaOccupata = ActiveSheet.Cells(44, 256).End(xlToLeft).Column - 1
For x = 5 To UltimaColonnaOccupata
Cells(43, x).Select
If Cells(43, x) <> 0 Then
Cells(43, x).Select
RigaDiPartenza = ActiveCell.Row
10
Cells(RigaDiPartenza, x).Select
If Cells(RigaDiPartenza, x) = "M" And Cells(RigaDiPartenza, x).Interior.ColorIndex = 2 Then
Cells(RigaDiPartenza, x).Interior.ColorIndex = 43
Cells(RigaDiPartenza, 38) = Cells(RigaDiPartenza, 38) + 1
Cells(43, x) = Cells(43, x) - 1
Else
RigaDiPartenza = RigaDiPartenza - 1
GoTo 10
End If
End If
Next x
End Sub
Sub ResettaContatoriDeiGiorni()
UltimaColonnaOccupata = ActiveSheet.Cells(11, 256).End(xlToLeft).Column - 1
For riga = 43 To 46
For x = 5 To UltimaColonnaOccupata
Cells(riga, x) = 1
Next x
Next riga
End Sub
Sub ImpostacontatoreCumulativoGiorni()
Range("AJ43").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-31]:R[3]C[-1])"
End Sub
Sub ImpostaContatoriUtente()
UltimoUtenteInLista = ActiveSheet.Cells(65536, 2).End(xlUp).Row
For colonna = 38 To 43
For riga = 11 To UltimoUtenteInLista
Cells(riga, colonna) = 0
Next riga
Next colonna
Range("AL8").Select
ActiveCell.FormulaR1C1 = "=MIN(R[3]C:R[34]C)"
Range("AM8").Select
ActiveCell.FormulaR1C1 = "=MIN(R[3]C:R[34]C)"
Range("AN8").Select
ActiveCell.FormulaR1C1 = "=MIN(R[3]C:R[34]C)"
Range("AO8").Select
ActiveCell.FormulaR1C1 = "=MIN(R[3]C:R[34]C)"
Range("AP8").Select
ActiveCell.FormulaR1C1 = "=MIN(R[3]C:R[34]C)"
Range("AQ8").Select
ActiveCell.FormulaR1C1 = "=MIN(R[3]C:R[34]C)"
End Sub
Sub ResettaColoriInTabella()
UltimaRigaOccupata = ActiveSheet.Cells(65536, 2).End(xlUp).Row
UltimaColonnaOccupata = ActiveSheet.Cells(11, 256).End(xlToLeft).Column - 8
Range(Cells(11, 5), Cells(UltimaRigaOccupata, UltimaColonnaOccupata)).Select
Selection.Interior.ColorIndex = 2
End Sub
Sub CancellaAreeDiCalcolo()
Range("E43:AJ46").Select
Selection.ClearContents
Range("AL8:AQ42").Select
Selection.ClearContents
Range("E11").Select
End Sub