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!

Moderatori: Anthony47, Flash30005
Range("A1:Z1000").Interior.Color = xlNone
Cells.Interior.Color = xlNone
Range("a2:a1000").Interior.ColorIndex = xlNone
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.se volessi far colorare un'altra m e un'altra per per ogni gg come devo fare?
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
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
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"
Torna a Applicazioni Office Windows
Macro per copiare testo e salvare in blocco note in formato Autore: kiuba |
Forum: Applicazioni Office Windows Risposte: 12 |
Visitano il forum: m.paolo e 17 ospiti