Corretta la colorazione al di sopra di 10 ritardi ma l'esempio del 56 riportato da te non rispecchia nessuna logica
l'unica cosa che posso pensare è che hai un numero "sporco" controlla che non ci siano spazi (eventualmente ridigita il numero)
quindi ti invio le macro corrette
- Codice: Seleziona tutto
Sub Ritardi()
Foglio = "Foglio1"
UR = Worksheets(Foglio).Range("C" & Rows.Count).End(xlUp).Row
Worksheets(Foglio).Range("N2:R" & UR).ClearContents
Worksheets(Foglio).Columns("C:G").Interior.ColorIndex = xlNone
For RR = 3 To UR
For CC = 8 To 12
Conta = 1
If Worksheets(Foglio).Cells(RR, CC) <> ".." Then
Num = Worksheets(Foglio).Cells(RR, CC).Value
For RRC = RR - 1 To RR
For CCC = 3 To 7
If Num = Worksheets(Foglio).Cells(RRC, CCC).Value Then Worksheets(Foglio).Cells(RRC, CCC).Interior.ColorIndex = 38
Next CCC
Next RRC
For RR2 = RR + 1 To UR
For CC2 = 3 To 7
If Num = Worksheets(Foglio).Cells(RR2, CC2).Value Then
UC = Worksheets(Foglio).Range("IV" & RR).End(xlToLeft).Column + 1
If UC < 14 Then UC = 14
Worksheets(Foglio).Cells(RR, UC).Value = Conta
GoTo Continua
End If
Next CC2
Conta = Conta + 1
Next RR2
End If
Continua:
Next CC
Next RR
Call ColorBack
End Sub
Sub ColorBack()
Foglio = "Foglio1"
UR = Worksheets(Foglio).Range("C" & Rows.Count).End(xlUp).Row
' Worksheets(Foglio).Columns("C:G").Interior.ColorIndex = xlNone
For RR = UR To 3 Step -1
For CC = 8 To 12
Conta = 1
ContaR = 0
If Worksheets(Foglio).Cells(RR, CC) <> ".." Then
Num = Worksheets(Foglio).Cells(RR, CC).Value
For RR2 = RR - 1 To 2 Step -1
ContaR = ContaR + 1
If ContaR > 10 Then GoTo SaltaC
For CC2 = 3 To 7
If Num = Worksheets(Foglio).Cells(RR2, CC2).Value Then
Conta = Conta + 1
If Conta = 2 Then
MRR2 = RR2
MCC2 = CC2
End If
If Conta = 3 Then
Worksheets(Foglio).Cells(MRR2, MCC2).Interior.ColorIndex = 6
Worksheets(Foglio).Cells(RR2, CC2).Interior.ColorIndex = 6
GoTo SaltaC
End If
End If
Next CC2
Next RR2
End If
Next CC
SaltaC:
Next RR
End Sub
Chiaramente devi avviare la macro "Ritardi"
ciao