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