macro colora celle

[robi1112]

ciao a tutti
qualche anno fa mi avete aiutato a costruire un foglio per la programmazione dei turni.
ora avrei un altro problema da proporvi:
sul foglio che spero di riuscire ad allegare vorrei che le lettere M e P si colorassero di verde e giallo per ogni giorno del mese ,escluso i festivi.( un giallo m e un verde m; un giallo p e un verde p).
la distribuzione dei colori dovrebbero essere piu' o meno uguali per tutti nell'arco del mese.
sto cercando da diverso tempo una macro da adattare,ma non sono cosi preparato....
potete aiutarmi?
vi allego file.
ciao
http://uploading.com/2fedc1cd/prova-xls

[robi1112]

aggiungo altro link
http://www.mediafire.com/?7hcd8y78jwfqov1

[KITT]

ciao robi1112,
volevo tentare nel fornirti qualce spunto ma non sono riuscito a scaricare il tuo file (ma forse e' colpa mia).

tuttavia ti chiedo:
che versione di excel usi? (immagino ti riferisca ad excel)
che struttura ha il file? fai un esempio con due o tre colonne...
che dati ci sono in queste colonne?
e soprattutto con che criterio vuoi che queste lettere si colorino?

Con qualche dettaglio in piu' metti in condizione gli utenti del forum di fornire degli spunti/soluzioni.

ciao

[robi1112]

ciao kitt e grazie per l'aiuto
uso excel 2003.
la struttura del foglio e cosi :

1 2 3 4 ecc

pino P N R R
lino N R M P
mino M N R R
tino P M R F
ecc N R R P
6ecc F R R F
ecc P M P P
8 M P N R
9 R P N R
10 M P R M
11 R R M M
ho da distribuire il personale su tre reparti (giallo,verde e bianco) e l'unico criterio e' quello di avere una rotazione equa durante il mese di tutti i soggetti.
ti allego link:
http://www.mediafire.com/view/7hcd8y78jwfqov1/prova.xls

[KITT]

ciao robi1112,
ho scaricato il file ma ho bisogno di ulteriori info:
- immagino che la situazione che hai allegata rappresenta il risultato finale che vuoi ottenere, ma la situazione da cui parti prevede la stessa tabella con le colonne bianche ad eccezione delle colonne relative ai festivi?
- le lettere ed il colore delle lettere le metti tu preventivamente con un tuo criterio personale?

scusa se ti chiedo ulteriori info, ma i colori in gioco sono di piu' rispetto a quanto riportato nel tuo post e cio mi crea difficolta a ricostruire la logica con cui hai strutturato la tabella...
fammi sapere ciao

[robi1112]

ciao kitt
si quello e' il risultato che voglio ottenere...
1-la tabella e' formata da colonne bianche,tranne che per i giorni festivi( ho utilizzato la formattazione condizionale)
2- le lettere corrispondono al turno (m= mattino;p= pomerigio; n= notte ) e per il colore delle lettere utilizzo una macro.
mi servirebbe la cella colorata solo sulle lettere m e p.

[KITT]

Ciao robi1112,
questo e' il codice che ho preparato per te, fai sapere se come criterio e' abbastanza equo o se sono necessarie delle modifiche o ulteriori discrimine di assegnazione.
Ciao.

Codice: Seleziona tutto

Sub ColoraCella()

'individua l'area da trattare
    UltimaRigaOccupata = ActiveSheet.Cells(65536, 2).End(xlUp).Row
    UltimaColonnaOccupata = ActiveSheet.Cells(11, 256).End(xlToLeft).Column - 1

For Riga = 11 To UltimaRigaOccupata
    For Colonna = 5 To UltimaColonnaOccupata
10
        'assegno una M verde 43
        If Colonna > UltimaColonnaOccupata Then GoTo 50
        Cells(Riga, Colonna).Select
        If ActiveCell = "M" Then
        Selection.Interior.ColorIndex = 43
        Colonna = Colonna + 1
        GoTo 20
            Else
                Colonna = Colonna + 1
                GoTo 10
        End If
   
20
        'assegno una M gialla 6
        If Colonna > UltimaColonnaOccupata Then GoTo 50
        Cells(Riga, Colonna).Select
        If ActiveCell = "M" Then
        Selection.Interior.ColorIndex = 6
        Colonna = Colonna + 1
        GoTo 30
            Else
                Colonna = Colonna + 1
                GoTo 20
        End If
   
30
        'assegno una M bianca
        If Colonna > UltimaColonnaOccupata Then GoTo 50
        Cells(Riga, Colonna).Select
        If ActiveCell = "M" Then
        Colonna = Colonna + 1
        GoTo 40
            Else
                Colonna = Colonna + 1
                GoTo 30
        End If
       
40
        Colonna = Colonna - 1
   
    Next Colonna
50
    'MsgBox "fine ciclo M"
    '=======================================================================
   
    'MsgBox "inizio ciclo P"
    '=======================================================================
    For Colonna = 5 To UltimaColonnaOccupata
60
        'assegno una P bianco
        If Colonna > UltimaColonnaOccupata Then GoTo 100
        Cells(Riga, Colonna).Select
        If ActiveCell = "P" Then
        Colonna = Colonna + 1
        GoTo 70
            Else
                Colonna = Colonna + 1
                GoTo 60
        End If
   
70
        'assegno una P verde 6
        If Colonna > UltimaColonnaOccupata Then GoTo 100
        Cells(Riga, Colonna).Select
        If ActiveCell = "P" Then
        Selection.Interior.ColorIndex = 43
        Colonna = Colonna + 1
        GoTo 80
            Else
                Colonna = Colonna + 1
                GoTo 70
        End If
   
80
        'assegno una M giallo
        If Colonna > UltimaColonnaOccupata Then GoTo 100
        Cells(Riga, Colonna).Select
        If ActiveCell = "P" Then
        Selection.Interior.ColorIndex = 6
        Colonna = Colonna + 1
        GoTo 90
            Else
                Colonna = Colonna + 1
                GoTo 80
        End If
       
90
        Colonna = Colonna - 1
   
   
    Next Colonna
100
    'MsgBox "fine ciclo P"

Next Riga

MsgBox "Processo concluso"

End Sub

[robi1112]

ciao kitt
perdona la mia ignoranza,ma di vba non so' proprio niente
come la inserisco nel mio foglio?
ciao

[KITT]

Ciao robi1112,
scusami ma visto che il colore delle lettere gia' le ottenevi con una macro l'ho dato per scontato.
apri excel, premi alt + F11 per entrare nel vb, copi il codice che ti ho scritto e lo incolli dove c'e' il codice che usi per assegnare il colore alle lettere.

poi per eseguire la macro usi lo stesso procedimento che usi per far eseguire la macro che ti colora le lettere.

fammi sapere ciao!!

[robi1112]

ciao kitt
con la macro che ho,le lettere me li scrive in automatico di quel colore.
ho provato ad assegnare la tua macro ad un pulsante , e funziona,ma probabilmente sono stato poco chiaro io
a me servirebbe che si colorasse di verde e giallo solo una cella contenente m e p per ogni giorno. (cioe': una m verde e una gialla,; una p verde e una p gialla).
se ci sono piu' m o p nello stesso giorno, queste saranno bianche.
spero di averti chiarito un po' di piu la situazione

[robi1112]

dimenticavo
l'area interessata va da e11:ai34
ciao

[KITT]

ok, ma potevi dare tutte le info subito ed in modo chiaro, cosi' adesso potevi gia' avere la soluzione.
ci sto lavorando...

[Anthony47]

Una macro come questa fa qualcosa di simile, non so se proprio quello che chiedi:

Codice: Seleziona tutto

Sub pmGY()
'by Anthony, http://www.pc-facile.com/forum/viewtopic.php?f=26&t=100384
Dim myYell() As Long, myGreen() As Long, myCY, myCG
Dim myUsers As Long, myDays As Long, I As Long, J As Long, maxY As Long, maxG As Long
Dim MinG As Long, MinY As Long, myMP As Long
Dim dayG As Boolean, dayY As Boolean, cDone As Boolean, dUnlock As Long, MP As Long, SwMP As String
'
'CREA UNA COPIA DEL FOGLIO prima di lavorarlo  ******
    ActiveSheet.Copy After:=Sheets(Sheets.Count)    '******
'
'calcola ultima riga utile:
With ActiveSheet.Range("E:AI")
  Set r = .Find(What:="*", After:=.Cells(1, 1), SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlFormulas)
End With
If Not r Is Nothing Then
    myUsers = r.Row
Else
    MsgBox ("Incapace di rilevare ultima riga in E:AI; processo terminato")
End If
'almeno >11...
If myUsers < 11 Then
    MsgBox ("L' area dei turni sembra vuote; processo terminato")
    Exit Sub
End If
myDays = 31
ReDim myYell(11 To myUsers, 1 To 2)
ReDim myGreen(11 To myUsers, 1 To 2)
'
'rimuove interior.color:
Cells(11, 5).Resize(myUsers, myDays).Interior.ColorIndex = xlNone
'
'loop: per I giorni / per J presenze
For I = 5 To myDays + 4
    If Cells(10, I) <> 1 Then    '1 in linea 10=Festivo (ignorare i festivi)
        For MP = 1 To 2
            myMP = 0
            If MP = 1 Then SwMP = "M" Else SwMP = "P"
            dUnlock = 0: dayY = False: dayG = False: cDone = False
reLoose:
'rientro anti deadlock:
            For J = 11 To myUsers
                DoEvents
                If Cells(J, I) = SwMP Then myMP = myMP + 1
                If Cells(J, I).Interior.ColorIndex = xlNone Then cDone = False Else cDone = True
                myCY = Application.WorksheetFunction.Index(myYell, 0, MP)
                myCG = Application.WorksheetFunction.Index(myGreen, 0, MP)
'ad uso bilanciamento:
                maxY = Application.WorksheetFunction.Max(myCY)
                maxG = Application.WorksheetFunction.Max(myCG)
                MinY = Application.WorksheetFunction.Min(myCY)
                MinG = Application.WorksheetFunction.Min(myCG)
'controlla se formattare Y:
                If UCase(Cells(J, I).Value) = SwMP Then
                    If (myYell(J, MP) - dUnlock) < maxY And dayY = False And cDone = False And (myYell(J, MP) - dUnlock) < MinY Then
                        Cells(J, I).Interior.Color = RGB(255, 255, 0)
                        myYell(J, MP) = myYell(J, MP) + 1
                        dayY = True
                        cDone = True
                    End If
'controlla se formattare G:
                    If (myGreen(J, MP) - dUnlock) < maxG And dayG = False And cDone = False And (myGreen(J, MP) - dUnlock) < MinG Then
                        Cells(J, I).Interior.Color = RGB(0, 255, 0)
                        myGreen(J, MP) = myGreen(J, MP) + 1
                        dayG = True
                        cDone = True
                    End If
                End If
                If (dayG = True And dayY = True) Then Exit For
            Next J
            If (dayG = False Or dayY = False) And (myMP + dayY + dayG) > 0 Then
                dUnlock = dUnlock + 1
                myMP = 0: beep: GoTo reLoose
            End If
'Test only:
'Range("AM11").Offset(0, MP * 2 - 2).Resize(50, 1).Value = myCY
'Range("AN11").Offset(0, MP * 2 - 2).Resize(50, 1).Value = myCG
        Next MP
    End If
Next I
MsgBox ("Completato")
End Sub


Per ridurre il rischio di effetti distruttivi, viene prima creata una copia del FOGLIO ATTIVO e la macro lavora sulla copia; quando sei certo del comportamento della macro puoi eliminare questo effetto cancellando la riga marcata ******.
La macro assume che in riga 10 ci sia 1 se la giornata e' festiva e quella colonna va ignorata.
Si assume che la tabella presenze occupi le colonne E:AI, dalla riga 11 in avanti.
Per meglio bilanciare i colori tra gli utenti e' bene che non ci siano righe vuote prima della fine dell' elenco.
Tutti i colori nelle celle dell' elenco vengono rimossi, mentre il colore dei testi viene ignorato.

Spero che sia di qualche utilita'

Ciao

[KITT]

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

[robi1112]

scutate per il ritardo ,ma ho dovuto fare delle prove e non essendo una cima .....
innanzitutto grazie per il lavoro che antony47 e kitt avete fatto.
nel frattempo ,avevo completato il foglio con altre righe e quindi ho dovuto adattare il vostro codice alla nuova disposizione e probabilmente ho commesso alcuni errori.(kitt non mi mandare al diavolo).
premettendo che sicuramente le modifiche che ho fatto del vostro codice non siano corrette:
il codice di antony47 e' molto veloce ,ma per le mie necessita' ha alcune lacune:
i colori non sono distribuiti equamente
i colori mi servono nell'area e16:ai37
vedo che mi si colorano anche le ultime 5 righe

per kitt
distribuzione piu' molto equa , ma molto piu' complicata per me da modificare per le mie nuove esigenze.(e qiu altri accidenti per me da kitt).
vi allego il file che usero' il prossimo anno.
la password per aprirlo e' robi1112
per visualizzare il vba la passord e' ROBI2224.
vi chiedo ancora scusa per le nuove richieste,e grazie per la pazienza
http://www.mediafire.com/view/26497ma4p ... _prova.xls

[KITT]

ciao robi1112,
provero' a dare uno sguardo stasera.
a presto.

[robi1112]

per farvi arrabbiare ancora di piu' ,
sarebbe meglio che non ci fossero due turni m e p dello stesso colore su 2 giorni consecutivi per la stessa riga (es. no m e p gialli per il lunedi e martedi alla stessa persona) :

[Anthony47]

Ho inserito nella macro la possibilita' di dichiarare la riga di inizio dell' elenco, e di controllare l' ultima riga sulla base dell' ultima cella compilata nell' intervallo B1:B37
Ho inoltre previsto di dichiarare la riga su cui e' indicato Festivo. Con queste nuove indicazioni la macro proposta diventa:

Codice: Seleziona tutto

Sub pmGY2()
'by Anthony, http://www.pc-facile.com/forum/viewtopic.php?f=26&t=100384
Dim myYell() As Long, myGreen() As Long, myCY, myCG
Dim myUsers As Long, myDays As Long, I As Long, J As Long, maxY As Long, maxG As Long
Dim MinG As Long, MinY As Long, myMP As Long, myInizio As Long, myFestivo As Long, leftCol As Boolean, FlDLock As Boolean
Dim dayG As Boolean, dayY As Boolean, cDone As Boolean, dUnlock As Long, MP As Long, SwMP As String
myTim = Timer
'
'CREA UNA COPIA DEL FOGLIO prima di lavorarlo  ******  <VEDI TESTO
'''''''    ActiveSheet.Copy After:=Sheets(Sheets.Count)
'
'calcola ultima riga utile:
myUsers = Evaluate("=MAX((B1:B37<>"""")*(ROW(B1:B37)))")
myInizio = 16           '<<< La riga iniziale
myFestivo = 15          '<<< La riga con la formula 1=Festivo
'
myDays = 31
ReDim myYell(myInizio To myUsers, 1 To 2)
ReDim myGreen(myInizio To myUsers, 1 To 2)
'
'rimuove interior.color:
Cells(11, 5).Resize(myUsers, myDays).Interior.ColorIndex = xlNone
'
'loop: per I giorni / per J presenze
For I = 5 To myDays + 4
    If Cells(myFestivo, I) <> 1 Then  '1 in linea myInizio=Festivo (ignorare i festivi)
        For MP = 1 To 2
            myMP = 0
            If MP = 1 Then SwMP = "M" Else SwMP = "P"
            dUnlock = 0: dayY = False: dayG = False: cDone = False
reLoose:
'rientro anti deadlock:
            For J = 11 To myUsers
                DoEvents
                If Cells(J, I) = SwMP Then myMP = myMP + 1
                If Cells(J, I - 1).Interior.Color > 65500 Or dUnlock > 1 Then leftCol = False Else leftCol = True
                If Cells(J, I).Interior.ColorIndex = xlNone Then cDone = False Else cDone = True
                myCY = Application.WorksheetFunction.Index(myYell, 0, MP)
                myCG = Application.WorksheetFunction.Index(myGreen, 0, MP)
'ad uso bilanciamento:
                maxY = Application.WorksheetFunction.Max(myCY)
                maxG = Application.WorksheetFunction.Max(myCG)
                MinY = Application.WorksheetFunction.Min(myCY)
                MinG = Application.WorksheetFunction.Min(myCG)
'controlla se formattare Y:
                If UCase(Cells(J, I).Value) = SwMP Then
                If Cells(J, I - 1).Interior.Color < 65500 Or Cells(J, I - 1).Interior.Color > 1000000 Or dUnlock > 1 Then leftCol = False Else leftCol = True
                    If (myYell(J, MP) - dUnlock) < maxY And dayY = False And cDone = False And (myYell(J, MP) - dUnlock) <= MinY And leftCol = False Then
                        Cells(J, I).Interior.Color = RGB(255, 255, 0)
                        myYell(J, MP) = myYell(J, MP) + 1
                        dayY = True
                        cDone = True
                    End If
'controlla se formattare G:
                If Cells(J, I - 1).Interior.Color > 65500 Or Cells(J, I - 1).Interior.Color > 1000000 Or dUnlock > 1 Then leftCol = False Else leftCol = True
                    If (myGreen(J, MP) - dUnlock) < maxG And dayG = False And cDone = False And (myGreen(J, MP) - dUnlock) <= MinG And leftCol = False Then
                        Cells(J, I).Interior.Color = RGB(0, 255, 0)
                        myGreen(J, MP) = myGreen(J, MP) + 1
                        dayG = True
                        cDone = True
                    End If
                End If
                If (dayG = True And dayY = True) Then Exit For
            Next J
            If (dayG = False Or dayY = False) And (myMP + dayY + dayG) > 0 Then
                dUnlock = dUnlock + 1: FlDLock = True
'                If dUnlock = 2 Then Stop
                myMP = 0: Beep: GoTo reLoose
            End If
FlDLock = False
'Test only:
'Range("AM1").Offset(myInizio - 1, MP * 2 - 2).Resize(50, 1).Value = myCY
'Range("AN1").Offset(myInizio - 1, MP * 2 - 2).Resize(50, 1).Value = myCG
        Next MP
    End If
Next I
MsgBox ("Processo terminato " & (Timer - myTim))
End Sub


Le istruzioni programmabili sono quelle marcate con <<<; l' istruzione che duplica il foglio di lavoro e' stata "pluricommentata" nel listing di sopra; se vuoi riattivarla devi solo cancellare gli apostrofi che trovi in testa all' istruzione.
La logica della macro per il resto non si discosta da quella precedente.

Ciao

[KITT]

ciao, qui il gioco comincia a farsi duro... ma non impossibile
Anthony47 ti ha modificato la sua soluzione e ha risposto prima, io ci sto ancora lavorando su.
Se la modifica di Anthony47 e' risolutiva avvisa tramite post, altrimenti dai altre info:
- perche' la riga 16 e' vuota e non compare nominativo?
- perche'i nominativi S e T non hanno turnistica compilata?
- perche' c'e' quell'area di nominativi messa a parte? (A1 B1 C1)?
mi serve saperlo poiche' devo mettere in condizione il programma di delimitare con coerenza l'area di intervento.
Fai sapere ciao.

[robi1112]

ciao
la macro di antony47 funziona alla perfezione.
ho assegnato la macro ad un pulsante per colorare il foglio: mi chiedevo se fosse possibile avere una macro per cancellare i colori assegnati.
per kitty:
la riga 16 e' vuota perche' per convenzione viene lasciata al caposala,che pero' non fa' i turni( viene utilizzata prevalentemente per segnare le ferie).
nelle celle b16:b37 vengono inseriti i nominativi che attualmente sono 17; dovrebbero aumentare a breve.....
l'area di nominativi a1,b1,c1 non fanno la stessa turnistica di quelli sopra ,e sopratutto hanno altre mansioni.
grazie a tutti e due per il tempo che mi avete dedicato e che mi dedicherete ancora,se vorrete.
ciao