Riepiloghi da creare

Sub univoci()
Dim ur, x, rr
rr = 1
Sheets("Riepilogo giorni dip").Activate
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ur = Cells(1048576, 35).End(xlUp).Row
If ur > 5 Then Range("$AI$6:$AI$" & ur) = ""
For x = 3 To 33
    ur = Cells(1048576, x).End(xlUp).Row
    Range(Cells(6, x), Cells(ur, x)).Copy
    Cells(rr, 36).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    rr = rr + ur
Next
ur = Cells(1048576, 36).End(xlUp).Row
ActiveSheet.Range("$AJ$1:$AJ$" & ur).RemoveDuplicates Columns:=1, Header:=xlNo
ur = Cells(1048576, 36).End(xlUp).Row
    ActiveWorkbook.Worksheets("Riepilogo giorni dip").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Riepilogo giorni dip").Sort.SortFields.Add Key:= _
        Range("AJ1:AJ" & ur), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Riepilogo giorni dip").Sort
        .SetRange Range("AJ1:AJ" & ur)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("AJ1:AJ" & ur).Copy
    Range("AI6").PasteSpecial
    Columns("AJ") = ""
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
MsgBox "Fatto"
End Sub

Sub UniqueList()
Dim r As Range
Dim rng As Range
Dim ar As Variant
Dim var As Variant

With CreateObject("scripting.dictionary")
    For j = 1 To Sheets.Count
        If Left(Sheets(j).Name, 9) <> "Riepilogo" Then
            ur = Sheets(j).Range("A" & Rows.Count).End(xlUp).Row
            For Each rng In Sheets(j).Range("A5:A" & ur)
                var = .Item(rng.Value)
                If .Item(rng.Value) = "codice" Then Stop
            Next
            ar = .Keys
        End If
    Next j
End With
Worksheets("Riepilogo giorni dip").Range("A6").Resize(UBound(ar) + 1) = Application.Transpose(ar)
End Sub

Sub UniqueList()
    Dim oDic As Object
    Dim rng As Range
    Dim arrKeys As Variant, arrItems As Variant
    Dim j As Long, ur As Long
    Set oDic = CreateObject("scripting.dictionary")
    With oDic
        For j = 1 To Sheets.Count
            If Left(Sheets(j).Name, 9) <> "Riepilogo" Then
                ur = Sheets(j).Range("A" & Rows.Count).End(xlUp).Row
                For Each rng In Sheets(j).Range("A5:A" & ur).Cells
                    If Not .Exists(rng.Value) Then
                        .Add Key:=rng.Value, Item:=rng.Offset(0, 1).Value
                    End If
                Next rng
            End If
        Next j
        arrKeys = .Keys
        arrItems = .Items
    End With
    With Worksheets("Riepilogo giorni dip")
        .Range("A6").Resize(oDic.Count) = Application.Transpose(arrKeys)
        .Range("B6").Resize(oDic.Count) = Application.Transpose(arrItems)
    End With
End Sub

Sub UniqueComm()
    Dim oDic As Object
    Dim rng As Range
    Dim arrKeys As Variant, arrItems As Variant
    Dim j As Long, ur As Long
    Set oDic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With oDic
        For j = 1 To Sheets.Count
            If Left(Sheets(j).Name, 9) <> "Riepilogo" Then
                Sheets(j).Select
                lc = Sheets(j).Cells(3, Columns.Count).End(xlToLeft).Column
                For Each rng In Sheets(j).Range(Cells(3, 28), Cells(3, lc))
                    If Not .Exists(rng.Value) Then
                        .Add Key:=rng.Value, Item:=rng.Value
                    End If
                Next rng
            End If
        Next j
        arrKeys = .Keys
    End With
    Worksheets("Riepilogo giorni commessa").Select
    Range("A6").Resize(oDic.Count) = Application.Transpose(arrKeys)
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub