Option Explicit
Sub Massimo()
Application.ScreenUpdating = False
Dim Rng_1 As Range, Rng_2 As Range
Dim x As Byte, y As Byte, k As Byte, z As Byte
With Worksheets("Ritardatari")
Range(.Cells(6, 3), .Cells(15, 12)).ClearContents
Range(.Cells(5, 16), .Cells(14, 25)).ClearContents
End With
For k = 2 To 32 Step 3
Select Case Cells(1, k).Value
Case "Bari"
Application.Goto Reference:="Bari"
Set Rng_1 = Range("C4:C93")
Set Rng_2 = Range("B4:C93")
z = 6
y = 16
Case "Cagliari"
Application.Goto Reference:="Cagliari"
Set Rng_1 = Range("F4:F93")
Set Rng_2 = Range("E4:F93")
z = 7
y = 17
Case "Firenze"
Application.Goto Reference:="Firenze"
Set Rng_1 = Range("I4:I93")
Set Rng_2 = Range("H4:I93")
z = 8
y = 18
Case Else
Exit For
End Select
ActiveWorkbook.Worksheets("Ritardatari per Ruota").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Ritardatari per Ruota").Sort.SortFields.Add Key:=Rng_1, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Ritardatari per Ruota").Sort
.SetRange Rng_2
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Aggiorna ritardi
With Worksheets("Ritardatari")
.Cells(z, 3).Value = Cells(4, k).Value
.Cells(z, 4).Value = Cells(4, k + 1).Value
.Cells(z, 5).Value = Cells(5, k).Value
.Cells(z, 6).Value = Cells(5, k + 1).Value
.Cells(z, 7).Value = Cells(6, k).Value
.Cells(z, 8).Value = Cells(6, k + 1).Value
.Cells(z, 9).Value = Cells(7, k).Value
.Cells(z, 10).Value = Cells(7, k + 1).Value
.Cells(z, 11).Value = Cells(8, k).Value
.Cells(z, 12).Value = Cells(8, k + 1).Value
.Cells(5, y).Value = Cells(4, k).Value
.Cells(6, y).Value = Cells(4, k + 1).Value
.Cells(7, y).Value = Cells(5, k).Value
.Cells(8, y).Value = Cells(5, k + 1).Value
.Cells(9, y).Value = Cells(6, k).Value
.Cells(10, y).Value = Cells(6, k + 1).Value
.Cells(11, y).Value = Cells(7, k).Value
.Cells(12, y).Value = Cells(7, k + 1).Value
.Cells(13, y).Value = Cells(8, k).Value
.Cells(14, y).Value = Cells(8, k + 1).Value
End With
Next k
Set Rng_1 = Nothing
Set Rng_2 = Nothing
Application.ScreenUpdating = True
Cells(4, 2).Select
End Sub