Ora dovrebbe essere corretto
- Codice: Seleziona tutto
Sub ColoraRiporta()
UR1 = 16
For RR1 = 5 To UR1 Step 3
Range("C" & RR1 & ":AX" & RR1).Interior.ColorIndex = xlNone
Next RR1
Range("A20:G1000").ClearContents
For CC1 = 3 To 43 Step 5
For RR1 = 5 To UR1 Step 3
NA1 = Format(Cells(RR1, CC1).Value, "00")
NA2 = Format(Cells(RR1, CC1 + 2).Value, "00")
Ambo1 = NA1 & NA2
RU1 = UCase(Left(Cells(1, CC1 - 1).Value, 2))
ContaA = 0
For CC2 = CC1 + 5 To 48 Step 5
For RR2 = 5 To UR1 Step 3
NA3 = Format(Cells(RR2, CC2).Value, "00")
NA4 = Format(Cells(RR2, CC2 + 2).Value, "00")
RU2 = UCase(Left(Cells(1, CC2 - 1).Value, 2))
Ambo2 = NA3 & NA4
If Ambo1 = Ambo2 Then
If RR1 = RR2 Then
Range(Cells(RR1, CC1), Cells(RR1, CC1 + 2)).Interior.Color = RGB(0, 255, 0)
Range(Cells(RR2, CC2), Cells(RR2, CC2 + 2)).Interior.Color = RGB(0, 255, 0)
Else
If Cells(RR1, CC1).Interior.ColorIndex = xlNone Then Range(Cells(RR1, CC1), Cells(RR1, CC1 + 2)).Interior.Color = RGB(180, 180, 180)
If Cells(RR2, CC2).Interior.ColorIndex = xlNone Then Range(Cells(RR2, CC2), Cells(RR2, CC2 + 2)).Interior.Color = RGB(180, 180, 180)
End If
If RU1 <> RU2 Then
If MAmbo <> Ambo2 Then
URR = Range("A" & Rows.Count).End(xlUp).Row + 1
If URR < 20 Then URR = 20
Range("A" & URR).Value = RU1 & "-" & RU2
Range("C" & URR).Value = NA1
Range("E" & URR).Value = NA2
If RR1 = RR2 Then Range("G" & URR).Value = Range("A" & RR1).Value
MAmbo = Ambo1
Else
URR = Range("A" & Rows.Count).End(xlUp).Row
If URR < 20 Then URR = 20
Range("A" & URR).Value = Range("A" & URR).Value & "-" & RU2
End If
End If
'End If
End If
Next RR2
Next CC2
Next RR1
Next CC1
URR = Range("A" & Rows.Count).End(xlUp).Row
For RR1 = 20 To URR - 1
NA1 = Format(Cells(RR1, 3).Value, "00")
NA2 = Format(Cells(RR1, 5).Value, "00")
For RR2 = URR To RR1 + 1 Step -1
NA3 = Format(Cells(RR2, 3).Value, "00")
NA4 = Format(Cells(RR2, 5).Value, "00")
If NA1 & NA2 = NA3 & NA4 Then Rows(RR2).Delete
Next RR2
Next RR1
End Sub
Ciao
