Seleziona Area e calcola Ritardi

Sub RitardiSA()
Dim Rs, Ra, r, c, rng, x, y, d, n

Range("Z2:AA37").ClearContents
For x = 1 To 36
    For y = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = Range(Cells(y, 3), Cells(y, 7))
        n = WorksheetFunction.CountIf(rng, x)
        If n >= 1 Then
            Ra = 0
        Else
            Ra = Ra + 1
        End If
        If Rs < Ra Then Rs = Ra
    Next y
    Cells(x + 1, 26) = Rs
    Cells(x + 1, 27) = Ra
    Ra = 0
    Rs = 0
Next x
End Sub

Set rng = Range(Cells(y, 3), Cells(y, 7))

Option Explicit
Sub ritardi()
Dim rng_estrazione As Range, rng_tabellone As Range
Dim rng_ritardi As Range, cella As Range, rng_risultati As Range

Dim c_estrazione As Object, tabellone As Object
Dim ritardo As Integer
Dim ur As Long, c As Long, r As Long
 
ur = Cells(Rows.Count, "d").End(xlUp).Row

Set rng_tabellone = Uni0n(Range("i2:i21"), Range("k2:k21"), _
    Range("m2:m21"), Range("o2:o21"), Range("q2:q21"))
Set rng_risultati = Uni0n(Range("j2:j21"), Range("l2:l21"), _
    Range("n2:n21"), Range("p2:p21"), Range("r2:r21"))
    
Set rng_ritardi = Range("c2:h" & ur)
Set rng_estrazione = Range("d1:h1")

Application.ScreenUpdating = False

rng_risultati.ClearContents

For Each cella In rng_ritardi
    If IsNumeric(cella.Value) = False Then
    Else
        Set c_estrazione = rng_estrazione.Find(cella.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not c_estrazione Is Nothing Then
            ritardo = 0
        Else
            ritardo = cella.Row - 1
        End If
       
    
        Set tabellone = rng_tabellone.Find(cella.Value, LookIn:=xlValues, lookat:=xlWhole)
        r = tabellone.Row
        c = tabellone.Column
        If Cells(r, c + 1).Value <> "" Then
        Else
            Cells(r, c + 1).Value = ritardo
        End If
    End If
Next cella
Application.ScreenUpdating = True

Set c_estrazione = Nothing
Set tabellone = Nothing
Set rng_ritardi = Nothing
Set rng_estrazione = Nothing
Set rng_tabellone = Nothing
Set rng_risultati = Nothing
End Sub

        If n >= 1 Then
            Ra = 0
        Else
            Ra = Ra + 1
        End If
        If Rs < Ra Then Rs = Ra

 Set Rng_ritardi = Range("C2:H" & Ur) 

 Set rng = Range(Cells(y, 4), Cells(y, 8)) 

 Range(Cells(w -1, 4), Cells(w -1, 8)) 

 For w = Ur - 1 To 1 Step -1 

For w = Ur To 1 Step -1

if cells(1,1) > cells(2,1) then 
    For w = Ur To 1 Step -1
else
    For w = 1 To Ur
endif

Sub RitardiSA()
Dim Rs, Ra, ur, r, c, rng, x, y, d, n
 
Range("Ritardi").ClearContents
r = 2: c = 27
For x = 1 To 90
    If x = 41 Then
        x = x
    End If
    ur = Cells(Rows.Count, 4).End(xlUp).Row
    If Cells(1, 1) > Cells(2, 1) Then
        For y = ur To 1 Step -1
            Set rng = Range(Cells(y, 4), Cells(y, 8))
            n = WorksheetFunction.CountIf(rng, x)
            If n >= 1 Then
                Ra = 0
            Else
                Ra = Ra + 1
            End If
            If Rs < Ra Then Rs = Ra
        Next y
    Else
        For y = 1 To ur
            Set rng = Range(Cells(y, 4), Cells(y, 8))
            n = WorksheetFunction.CountIf(rng, x)
            If n >= 1 Then
                Ra = 0
            Else
                Ra = Ra + 1
            End If
            If Rs < Ra Then Rs = Ra
        Next y
    End If
    Cells(r, c) = Rs
    Cells(r + 1, c) = Ra
    c = c + 1
    If c = 37 Then r = r + 3: c = 27
    Ra = 0
    Rs = 0
Next x
End Sub

Option Explicit

Sub Ritardi()
Application.ScreenUpdating = False
Dim NDR As Range, Rng As Range
Dim Ur As Long, x As Long, z As Long, RgP As Long, Rtd As Long, Est As Long
Dim y As Byte, NRc As Byte

    Ur = Cells(Rows.Count, "D").End(xlUp).Row
        Range(Cells(2, 24), Cells(91, 24)).ClearContents
    RgP = Ur - 1
        For x = Ur To 2 Step -1
            For y = 4 To 8
                Rtd = 0
                NRc = Cells(x, y).Value
                Set NDR = Cells(x, y)
                    For z = RgP To 1 Step -1
                        Set Rng = Range(Cells(z, 4), Cells(z, 8))
                    Est = WorksheetFunction.CountIf(Rng, NRc)
                        If Est = 0 Then
                            Rtd = Rtd + 1
                                If z = 1 And Cells(NRc + 1, 24).Value = "" Then Cells(NRc + 1, 24).Value = "Oltre " & Rtd
                        Else
                            If Cells(NRc + 1, 24).Value = "" Then Cells(NRc + 1, 24).Value = Rtd
                                Exit For
                        End If
                    Next z
            Next y
                RgP = RgP - 1
        Next x
Application.ScreenUpdating = True
End Sub

 Set Rng = Range(Cells(y, 4), Cells(y, 8))
            n = WorksheetFunction.CountIf(Rng, x)

Option Explicit
Sub ritardi_date_crescenti()
Dim rng_estrazione As Range, rng_tabellone As Range
Dim rng_ritardi As Range, cella As Range, rng_risultati As Range

Dim c_estrazione As Object, tabellone As Object
Dim ritardo As Integer
Dim ur As Long, c As Long, r As Long

Sheets("Foglio2").Activate

ur = Cells(Rows.Count, "d").End(xlUp).Row

Set rng_tabellone = Uni0n(Range("i2:i21"), Range("k2:k21"), _
    Range("m2:m21"), Range("o2:o21"), Range("q2:q21"))
Set rng_risultati = Uni0n(Range("j2:j21"), Range("l2:l21"), _
    Range("n2:n21"), Range("p2:p21"), Range("r2:r21"))
    
Set rng_ritardi = Range("c1:h" & ur)
Set rng_estrazione = Range("d" & ur & ":" & "h" & ur)

Application.ScreenUpdating = False

rng_risultati.ClearContents

For Each cella In rng_ritardi
    If IsNumeric(cella.Value) = False Then
    Else
        Set c_estrazione = rng_estrazione.Find(cella.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not c_estrazione Is Nothing Then
            ritardo = 0
        Else
            ritardo = ur - cella.Row
        End If
       
    
        Set tabellone = rng_tabellone.Find(cella.Value, LookIn:=xlValues, lookat:=xlWhole)
        r = tabellone.Row
        c = tabellone.Column
        Cells(r, c + 1).Value = ritardo
        
    End If
Next cella
Application.ScreenUpdating = True

Set c_estrazione = Nothing
Set tabellone = Nothing
Set rng_ritardi = Nothing
Set rng_estrazione = Nothing
Set rng_tabellone = Nothing
Set rng_risultati = Nothing
End Sub