VBA, Modification d'une macro, Trier des donnees par statut ou ordre de grandeur

Option Explicit
Sub test()
Dim a, b(), w(), i As Long, e, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Feuil1").Cells(1).CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            If Not dico.exists(a(i, 4)) Then
                ReDim w(1 To 4)
                ReDim b(1 To UBound(a, 1), 1 To 4)
                Set w(1) = CreateObject("Scripting.Dictionary")
                w(1).CompareMode = 1
                w(2) = 1
                w(3) = Array(4, 4)
                b(w(2), w(3)(0) - 3) = "Nbre": b(w(2), w(3)(0) - 2) = "Cabin"
                b(w(2), w(3)(0) - 1) = "Guest 1": b(w(2), w(3)(0)) = "Latitude 1"
                w(4) = b
                dico.Item(a(i, 4)) = w
            End If
            w = dico.Item(a(i, 4))
            b = w(4)
            If Not w(1).exists(a(i, 1)) Then
                w(2) = w(2) + 1
                b(w(2), w(3)(0) - 2) = a(i, 1)
                b(w(2), w(3)(0) - 1) = a(i, 3)
                b(w(2), w(3)(0)) = a(i, 5)
                w(1)(a(i, 1)) = w(2)
            Else
                w(3)(1) = w(3)(1) + 2
                If UBound(b, 2) < w(3)(1) Then
                    ReDim Preserve b(1 To UBound(b, 1), 1 To w(3)(1))
                End If
                b(w(1)(a(i, 1)), w(3)(1) - 1) = a(i, 3)
                b(w(1)(a(i, 1)), w(3)(1)) = a(i, 5)
            End If
            w(4) = b
            dico.Item(a(i, 4)) = w
        Next
    End With
    For Each e In dico.keys
        w = dico.Item(e): b = w(4)
        b(2, 1) = dico.Item(e)(1).Count
        w(4) = b: dico.Item(e) = w
    Next
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    For Each e In dico.keys
        On Error Resume Next
        Application.DisplayAlerts = False
        Sheets(e).Delete
        Sheets.Add().Name = e
        On Error GoTo 0
        With Sheets(e).Cells(1)
            With .Resize(dico.Item(e)(2), UBound(dico.Item(e)(4), 2))
                .Columns(2).NumberFormat = "@"
                .Value = dico.Item(e)(4)
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .Font.Name = "calibri"
                .Font.Size = 9
                With .Cells(1, 3).Resize(, 2)
                    If UBound(dico.Item(e)(4), 2) > 4 Then
                        .AutoFill .Resize(, UBound(dico.Item(e)(4), 2) - 2)
                    End If
                End With
                With .Cells(2, 1)
                    .BorderAround Weight:=xlThin
                    .HorizontalAlignment = xlCenter
                    .Interior.ColorIndex = 15
                End With
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .HorizontalAlignment = xlCenter
                    .Interior.ColorIndex = 6
                    .RowHeight = 16
                    .Font.Size = 10
                End With
                .Columns.AutoFit
            End With
        End With
    Next
    Set dico = Nothing
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub