Moderatori: Anthony47, Flash30005
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
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
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
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
Torna a Applicazioni Office Windows
Macro modifica date scelta periodo Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 11 |
Mettere tutto MAIUSCOLO un range di celle Autore: raimea |
Forum: Applicazioni Office Windows Risposte: 7 |
Supporto per sviluppo macro VBA Ordinare per data Autore: Carletto Ribolla |
Forum: Applicazioni Office Windows Risposte: 3 |
Visitano il forum: Nessuno e 31 ospiti