Valutazione 4.87/ 5 (100.00%) 5838 voti

Condividi:        

macro colora celle

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Re: macro colora celle

Postdi KITT » 05/11/13 12:21

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!
:)
KITT
XP - OFFICE 2003 - ENG
WIN 7 - OFFICE 2010 - ENG
Avatar utente
KITT
Utente Junior
 
Post: 71
Iscritto il: 16/05/11 08:20

Sponsor
 

Re: macro colora celle

Postdi Flash30005 » 05/11/13 17:36

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
Flash
Win7 + Office 2010 Ita
"Fotografica" al servizio dell'immagine

Ottime opportunità di lavoro (part-time o full-time) con guadagni immediati. Info in MP
Avatar utente
Flash30005
Moderatore
 
Post: 8460
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: macro colora celle

Postdi robi1112 » 06/11/13 15:10

scusate l'ignoranza ma dove devo inserire il codice?
robi1112
Utente Junior
 
Post: 45
Iscritto il: 29/10/13 17:05

Re: macro colora celle

Postdi robi1112 » 06/11/13 16:05

ho provato ad inserire il codice ma mi colora le celle di azzurro!?!
dove sbaglio?
grazie
robi1112
Utente Junior
 
Post: 45
Iscritto il: 29/10/13 17:05

Re: macro colora celle

Postdi robi1112 » 06/11/13 16:48

per antony47
se volessi far colorare un'altra m e un'altra per per ogni gg come devo fare?
grazie
robi1112
Utente Junior
 
Post: 45
Iscritto il: 29/10/13 17:05

Re: macro colora celle

Postdi Flash30005 » 06/11/13 17:59

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
Flash
Win7 + Office 2010 Ita
"Fotografica" al servizio dell'immagine

Ottime opportunità di lavoro (part-time o full-time) con guadagni immediati. Info in MP
Avatar utente
Flash30005
Moderatore
 
Post: 8460
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: macro colora celle

Postdi Anthony47 » 07/11/13 02:43

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
Anthony
Win7 + Office 2010 Ita; Win 7 + Office 2013 Ita
Xp + Office 2003 Ita
E voi cosa usate? (per istruzioni vedere viewtopic.php?f=26&t=97449)
Avatar utente
Anthony47
Moderatore
 
Post: 13899
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: macro colora celle

Postdi robi1112 » 07/11/13 09:37

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
Utente Junior
 
Post: 45
Iscritto il: 29/10/13 17:05

Re: macro colora celle

Postdi robi1112 » 07/11/13 09:57

allora
smanettando un po' sono riuscito a modificare il colore della cella.
resta sempre il problema dell'area...
robi1112
Utente Junior
 
Post: 45
Iscritto il: 29/10/13 17:05

Re: macro colora celle

Postdi robi1112 » 07/11/13 10:00

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
robi1112
Utente Junior
 
Post: 45
Iscritto il: 29/10/13 17:05

Re: macro colora celle

Postdi Anthony47 » 07/11/13 14:17

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
Anthony
Win7 + Office 2010 Ita; Win 7 + Office 2013 Ita
Xp + Office 2003 Ita
E voi cosa usate? (per istruzioni vedere viewtopic.php?f=26&t=97449)
Avatar utente
Anthony47
Moderatore
 
Post: 13899
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: macro colora celle

Postdi robi1112 » 07/11/13 22:02

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
robi1112
Utente Junior
 
Post: 45
Iscritto il: 29/10/13 17:05

Re: macro colora celle

Postdi Anthony47 » 08/11/13 00:44

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...
Anthony
Win7 + Office 2010 Ita; Win 7 + Office 2013 Ita
Xp + Office 2003 Ita
E voi cosa usate? (per istruzioni vedere viewtopic.php?f=26&t=97449)
Avatar utente
Anthony47
Moderatore
 
Post: 13899
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: macro colora celle

Postdi robi1112 » 08/11/13 12:23

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
robi1112
Utente Junior
 
Post: 45
Iscritto il: 29/10/13 17:05

Re: macro colora celle

Postdi Anthony47 » 08/11/13 13:14

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
Anthony
Win7 + Office 2010 Ita; Win 7 + Office 2013 Ita
Xp + Office 2003 Ita
E voi cosa usate? (per istruzioni vedere viewtopic.php?f=26&t=97449)
Avatar utente
Anthony47
Moderatore
 
Post: 13899
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: macro colora celle

Postdi robi1112 » 08/11/13 14:35

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
robi1112
Utente Junior
 
Post: 45
Iscritto il: 29/10/13 17:05

Re: macro colora celle

Postdi Anthony47 » 09/11/13 00:31

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
Anthony
Win7 + Office 2010 Ita; Win 7 + Office 2013 Ita
Xp + Office 2003 Ita
E voi cosa usate? (per istruzioni vedere viewtopic.php?f=26&t=97449)
Avatar utente
Anthony47
Moderatore
 
Post: 13899
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: macro colora celle

Postdi robi1112 » 09/11/13 12:21

grazie antony
ora funziona tutto....
grazie mille
robi1112
Utente Junior
 
Post: 45
Iscritto il: 29/10/13 17:05

Re: macro colora celle

Postdi robi1112 » 02/12/13 12:37

ciao
ora la macro mi colora le lettere "M" e "P".
se volessi far colorare anche la lettera "N" cosa dovrei modificare?
grazie
robi1112
Utente Junior
 
Post: 45
Iscritto il: 29/10/13 17:05

Re: macro colora celle

Postdi Anthony47 » 03/12/13 01:20

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
Anthony
Win7 + Office 2010 Ita; Win 7 + Office 2013 Ita
Xp + Office 2003 Ita
E voi cosa usate? (per istruzioni vedere viewtopic.php?f=26&t=97449)
Avatar utente
Anthony47
Moderatore
 
Post: 13899
Iscritto il: 21/03/06 16:03
Località: Ivrea

Precedente

Torna a Applicazioni Office Windows


Topic correlati a "macro colora celle":


Chi c’è in linea

Visitano il forum: Nessuno e 23 ospiti