Option Explicit
Sub Rieilogo_GARE()
Application.ScreenUpdating = False
Const Gare As Byte = 10
Dim x As Byte
Dim NRcGr As Long, NRcRp As Long
Dim Gr As String
NRcRp = Range("Riepilogo!A" & Rows.Count).End(xlUp).Row + 1
If NRcRp < 2 Then NRcRp = 2
Range(Cells(2, 1), Cells(NRcRp, 11)).ClearContents
For x = 1 To Gare
Select Case x
Case 1
Gr = "GARA1"
NRcGr = Range("GARA1!A" & Rows.Count).End(xlUp).Row + 1
Case 2
Gr = "GARA2"
NRcGr = Range("GARA2!A" & Rows.Count).End(xlUp).Row + 1
Case 3
Gr = "GARA3"
NRcGr = Range("GARA3!A" & Rows.Count).End(xlUp).Row + 1
Case 4
Gr = "GARA4"
NRcGr = Range("GARA4!A" & Rows.Count).End(xlUp).Row + 1
Case 5
Gr = "GARA5"
NRcGr = Range("GARA5!A" & Rows.Count).End(xlUp).Row + 1
Case 6
Gr = "GARA6"
NRcGr = Range("GARA6!A" & Rows.Count).End(xlUp).Row + 1
Case 7
Gr = "GARA7"
NRcGr = Range("GARA7!A" & Rows.Count).End(xlUp).Row + 1
Case 8
Gr = "GARA8"
NRcGr = Range("GARA8!A" & Rows.Count).End(xlUp).Row + 1
Case 9
Gr = "GARA9"
NRcGr = Range("GARA9!A" & Rows.Count).End(xlUp).Row + 1
Case 10
Gr = "GARA10"
NRcGr = Range("GARA10!A" & Rows.Count).End(xlUp).Row + 1
End Select
NRcRp = Range("Riepilogo!A" & Rows.Count).End(xlUp).Row + 1
With Worksheets(Gr)
Range(.Cells(2, 1), .Cells(NRcGr, 1)).Copy Cells(NRcRp, 1)
Range(.Cells(2, 4), .Cells(NRcGr, 6)).Copy Cells(NRcRp, 2)
Range(.Cells(2, 8), .Cells(NRcGr, 8)).Copy Cells(NRcRp, 5)
Range(.Cells(2, 9), .Cells(NRcGr, 9)).Copy Cells(NRcRp, 6)
End With
Next x
' Sort
Columns("A:F").Select
ActiveWorkbook.Worksheets("Riepilogo").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Riepilogo").Sort.SortFields.Add Key:=Range( _
"C2:C310"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Riepilogo").Sort.SortFields.Add Key:=Range( _
"B2:B310"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Riepilogo").Sort.SortFields.Add Key:=Range( _
"A2:A310"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Riepilogo").Sort
.SetRange Range("A1:F310")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Univoci
Columns("B:D").Copy Range("I1")
Application.CutCopyMode = False
ActiveSheet.Range("$H$1:$J$310").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
' Sort Univoci
NRcRp = Range("Riepilogo!H" & Rows.Count).End(xlUp).Row
Columns("H:L").Select
ActiveWorkbook.Worksheets("Riepilogo").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Riepilogo").Sort.SortFields.Add Key:=Range("J2:J" & NRcRp), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Riepilogo").Sort.SortFields.Add Key:=Range("L2:L341" & NRcRp), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Riepilogo").Sort.SortFields.Add Key:=Range("I2:I341" & NRcRp), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Riepilogo").Sort.SortFields.Add Key:=Range("H2:H341" & NRcRp), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Riepilogo").Sort
.SetRange Range("H1:L341" & NRcRp)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Cells(2, 2).Select
Sheets("Classifiche").Select
Application.ScreenUpdating = True
Cells(1, 1).Select
End Sub
|