macro colora celle

[KITT]

ciao, quindi se funziona non e' necessario che io continui nello sviluppo della mia alternativa.
Per resettare i colori assegnati prova questa:
(si assume che il renge di intervento sia fisso)
Range("E16:AI43").Interior.ColorIndex = 2

mi ha fatto comunque piacere aver contribuito in qualche modo, alla prox ciao!

[Flash30005]

Il coloroindex 2 è un colore (bianco)
mentre eliminare i colori (fondo "trasparente") devi usare

Codice: Seleziona tutto

Range("A1:Z1000").Interior.Color = xlNone

adatta il range alle tue esigenze
altrimenti per l'intero foglio puoi usare

Codice: Seleziona tutto

Cells.Interior.Color = xlNone

ciao

[robi1112]

scusate l'ignoranza ma dove devo inserire il codice?

[robi1112]

ho provato ad inserire il codice ma mi colora le celle di azzurro!?!
dove sbaglio?
grazie

[robi1112]

per antony47
se volessi far colorare un'altra m e un'altra per per ogni gg come devo fare?
grazie

[Flash30005]

Ti ho passato il codice per la versione 2010 di Excel
per la 2003 usa questo codice

Codice: Seleziona tutto

Range("a2:a1000").Interior.ColorIndex = xlNone

Ciao

[Anthony47]

C' e' un messaggio di Flash, vedi sopra.

se volessi far colorare un'altra m e un'altra per per ogni gg come devo fare?

La macro non era stata fatta per poterci impostare il numero dei colori, quindi ho dovuto fare numerose aggiunte, che ricalcano quanto fatto per il Giallo e Verde.
Il nuovo codice:

Codice: Seleziona tutto

Sub pmGY23()
'by Anthony, http://www.pc-facile.com/forum/viewtopic.php?f=26&t=100384
Dim myYell() As Long, myGreen() As Long, myBlue() As Long, myCY, myCG, myCB
Dim myUsers As Long, myDays As Long, I As Long, J As Long, maxY As Long, maxG As Long, maxB As Long
Dim MinG As Long, MinY As Long, MinB As Long, myMP As Long, myInizio As Long, myFestivo As Long, leftCol As Boolean, FlDLock As Boolean
Dim dayG As Boolean, dayY As Boolean, dayB 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
mycolors = 3            '<<< Quanti colori applicare
'
myDays = 31
ReDim myYell(myInizio To myUsers, 1 To 3)
ReDim myGreen(myInizio To myUsers, 1 To 3)
ReDim myBlue(myInizio To myUsers, 1 To 3)

'
'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: dayB = False
reLoose:
'rientro anti deadlock:
            For J = myInizio 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)
                myCB = Application.WorksheetFunction.Index(myBlue, 0, MP)
'ad uso bilanciamento:
                maxY = Application.WorksheetFunction.Max(myCY)
                maxG = Application.WorksheetFunction.Max(myCG)
                maxB = Application.WorksheetFunction.Max(myCB)
               
                MinY = Application.WorksheetFunction.Min(myCY)
                MinG = Application.WorksheetFunction.Min(myCG)
                MinB = Application.WorksheetFunction.Min(myCB)
               
'controlla se formattare Y:
                If UCase(Cells(J, I).Value) = SwMP Then
                    If Cells(J, I - 1).Interior.Color <> 65535 Or Cells(J, I - 1).Interior.Color > 16777210 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 <> 65280 Or Cells(J, I - 1).Interior.Color > 16777210 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
    'controlla se formattare B:
                    If mycolors > 2 Then
                    If Cells(J, I - 1).Interior.Color <> 16711680 Or Cells(J, I - 1).Interior.Color > 16777210 Or dUnlock > 1 Then leftCol = False Else leftCol = True
                        If (myBlue(J, MP) - dUnlock) < maxB And dayB = False And cDone = False And (myBlue(J, MP) - dUnlock) <= MinB And leftCol = False Then
                            Cells(J, I).Interior.Color = RGB(0, 0, 255)
                            myBlue(J, MP) = myBlue(J, MP) + 1
                            dayB = True
                            cDone = True
                        End If
                    Else
                        dayB = True
                    End If
                End If
                If (dayG = True And dayY = True And dayB = 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 * 3 - 3).Resize(50, 1).Value = myCY
'Range("AN1").Offset(myInizio - 1, MP * 3 - 3).Resize(50, 1).Value = myCG
'Range("AO1").Offset(myInizio - 1, MP * 3 - 3).Resize(50, 1).Value = myCB
        Next MP
    End If
Next I
MsgBox ("Processo terminato " & (Timer - myTim))
End Sub


Modificando il contenuto della cella marcata <<< Quanti colori applicare si potra' scegliere se applicare 2 (valore minore di 3) oppure 3 (valore >=3)
Il terzo colore sara' Blu.

Ciao

[robi1112]

ciao antony47
il nuovo codice mi da' qualche problema
non mi colora tutta l'area e16:ai37
se dovessi scegliere un colore piu' chiaro del blu cosa dovrei cambiare?
quando stampo i turni non riesco a visualizzare le lettere nella cella
ciao

[robi1112]

allora
smanettando un po' sono riuscito a modificare il colore della cella.
resta sempre il problema dell'area...

[robi1112]

vedo che mi assegna due blu (modificato in azzurro) per due giorni consecutivi alla stessa persona.
e' possibile fare come per il verde e il giallo?
grazie

[Anthony47]

La macro considera che l' ultima riga da usare e' l' ultima che in colonna B ha un nominativo.

Se hai modificato il colore Blu ("Interior.Color = RGB(0, 0, 255)") dovresti anche modificare l' istruzione che serve a evitare la doppia assegnazione dello stesso colore, nel tuo caso devi modificare questa:
If Cells(J, I - 1).Interior.Color <> 16711680 Or Cells(J, I - 1).Interior.Color > 16777210 Or dUnlock > 1 Then leftCol = False Else leftCol = True
Quale valore usare al posto di 16711680 lo devi calcolare sapendo quale RGB hai usato, oppure lo leggi da una cella formattata con quel colore.

Ciao

[robi1112]

ciao antony47
sto lavorando sul foglio di gennaio
la macro che mi hai dato di tre colori mi colora solo fino al 14 gennaio.
sto provando con la tua e non con la mia modificata .
mi dovro' rassegnare ai due colori?
perdonami ,ma per cambiare il colore ci ho speso tutta la mattina!!!!
ma almeno ho imparato qualcosa.
buonaserata

[Anthony47]

Ti ho detto prima quale logica viene usata per calcolare l' ultima riga, il tuo ultimo messaggio e' vago e non aggiunge nulla. Ne' capisco cosa c' entra il numero riga con 2-3 colori...

[robi1112]

ok. problema risolto ma ora me se ne presenta un'altro.
il tutto funziona finche' non metto la protezione al foglio.
con la protezione mi da il messaggio: x400.
la protezione mi serve per proteggere tutte quelle celle che contengono formule.
soluzioni?
grazie per la pazienza
http://www.mediafire.com/?vrrqcb4wfrs6bsr

[Anthony47]

Risolto come??

Puoi usare il parametro UserInterfaceOnly, cioe' proteggendo il foglio solo da interventi manuali non via macro, come suggerito da Ricky in questa discussione: viewtopic.php?p=579223#p579223

Ciao

[robi1112]

ok per la protezione.
riguardando attentamente i turni,vedo che in alcuni gg non viene assegnato il colore celeste( es 7 gennaio;il 3 e 4 solo un celeste;il 15 nessun celeste ecc)
provi a verificare se la macro e' corretta?
grazie
pasw:robi1112
http://www.mediafire.com/?hvfx2u694wdffy1

[Anthony47]

Nell' aggiunta del terzo colore s' era perso un pezzo nella riga ora aggiornata in
If (dayG = False Or dayY = False Or dayB = False) And (myMP + dayY + dayG + dayB) > 0 Then
Ne ho approfittato per inserire uno scrambling della sequenza di ricerca per diminuire la frequenza di duplicazione colore, e per indicare in modo esplicito, in testa alla macro, i tre colori che saranno usati.
La nuova macro e' questa:

Codice: Seleziona tutto

Sub pmGY23XA()
'by Anthony, http://www.pc-facile.com/forum/viewtopic.php?f=26&t=100384
'migliore gestione dei colori adiacenti
'piu' facile gestione dei colori da assegnare
'
Dim myYell() As Long, myGreen() As Long, myBlue() As Long, myCY, myCG, myCB
Dim myUsers As Long, myDays As Long, I As Long, J As Long, maxY As Long, maxG As Long, maxB As Long
Dim MinG As Long, MinY As Long, MinB As Long, myMP As Long, myInizio As Long, myFestivo As Long, leftCol As Boolean, FlDLock As Boolean
Dim dayG As Boolean, dayY As Boolean, dayB As Boolean, cDone As Boolean, dUnlock As Long, MP As Long, SwMP As String
Dim jJ As Long, yColor As Long, gColor As Long, bColor As Long
myTim = Timer
Randomize
yColor = RGB(255, 255, 0)   '<<< Codice colore Giallo
gColor = RGB(0, 255, 0)     '<<< Codice colore Verde
bColor = RGB(0, 255, 255)    '<<< Codice colore Blu
'
'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
mycolors = 3            '<<< N° colori: <3: 2 colori; >=3: 3 colori
'
myDays = 31
ReDim myYell(myInizio To myUsers, 1 To 3)
ReDim myGreen(myInizio To myUsers, 1 To 3)
ReDim myBlue(myInizio To myUsers, 1 To 3)

'
'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
    Cells(myInizio, I).Resize(myUsers - myInizio + 1, 1).Interior.ColorIndex = xlNone
    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: dayB = False
reLoose:
'rientro anti deadlock:
            myrand = Int(Rnd() * myUsers)
            For jJ = myInizio To myUsers
                J = (jJ + myrand) Mod (myUsers - myInizio + 1) + myInizio
                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)
                myCB = Application.WorksheetFunction.Index(myBlue, 0, MP)
'ad uso bilanciamento:
                maxY = Application.WorksheetFunction.Max(myCY)
                maxG = Application.WorksheetFunction.Max(myCG)
                maxB = Application.WorksheetFunction.Max(myCB)
               
                MinY = Application.WorksheetFunction.Min(myCY)
                MinG = Application.WorksheetFunction.Min(myCG)
                MinB = Application.WorksheetFunction.Min(myCB)
               
'controlla se formattare Y:
                If UCase(Cells(J, I).Value) = SwMP Then
cY:
                    If Cells(J, I - 1).Interior.Color <> yColor Or Cells(J, I - 1).Interior.Color > 16777210 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 = yColor
                            myYell(J, MP) = myYell(J, MP) + 1
                            dayY = True
                            cDone = True
                        End If
    'controlla se formattare G:
                        If I Mod 2 = 0 Then GoTo cB
cG:
                    If Cells(J, I - 1).Interior.Color <> gColor Or Cells(J, I - 1).Interior.Color > 16777210 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 = gColor
                            myGreen(J, MP) = myGreen(J, MP) + 1
                            dayG = True
                            cDone = True
                        End If
                        If I Mod 2 = 0 Then GoTo ECB
    'controlla se formattare B:
cB:
                    If mycolors > 2 Then
                        If Cells(J, I - 1).Interior.Color <> bColor Or Cells(J, I - 1).Interior.Color > 16777210 Or dUnlock > 1 Then leftCol = False Else leftCol = True
                        If (myBlue(J, MP) - dUnlock) < maxB And dayB = False And cDone = False And (myBlue(J, MP) - dUnlock) <= MinB And leftCol = False Then
                            Cells(J, I).Interior.Color = bColor
                            myBlue(J, MP) = myBlue(J, MP) + 1
                            dayB = True
                            cDone = True
                        End If
                    Else
                        dayB = True
                    End If
                    If I Mod 2 = 0 Then GoTo cG
ECB:
                End If
                If (dayG = True And dayY = True And dayB = True) Then Exit For
            Next jJ
            If (dayG = False Or dayY = False Or dayB = False) And (myMP + dayY + dayG + dayB) > 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 * 3 - 3).Resize(50, 1).Value = myCY
'Range("AN1").Offset(myInizio - 1, MP * 3 - 3).Resize(50, 1).Value = myCG
'Range("AO1").Offset(myInizio - 1, MP * 3 - 3).Resize(50, 1).Value = myCB

        Next MP
    End If
Next I
MsgBox ("Processo terminato " & (Timer - myTim))
End Sub


Va notato che ora, rilanciando la macro, la sequenza di colorazione variera' ogni volta
Ciao

[robi1112]

grazie antony
ora funziona tutto....
grazie mille

[robi1112]

ciao
ora la macro mi colora le lettere "M" e "P".
se volessi far colorare anche la lettera "N" cosa dovrei modificare?
grazie

[Anthony47]

La macro era nata per colorare una M e una P, poi era stata tacconata per colorare due M e due P; proviamo col taccone al taccone...
Invece di
For MP = 1 To 2
myMP = 0
If MP = 1 Then SwMP = "M" Else SwMP = "P"
Prova a inserire

Codice: Seleziona tutto

        For MP = 1 To 3
            myMP = 0
            If MP = 1 Then SwMP = "M"
            If MP = 2 Then SwMP = "P"
            If MP = 3 Then SwMP = "N"

Ciao