XL 2013 Carnet de zone

Sub Davy76()
Dim T, i As Long, Dico, Parité As String, TT, DL As Long, TFin(), x As Integer
Set Dico = CreateObject("Scripting.Dictionary")

With Worksheets("Zone") ' tri alphabetique de la feuille
    DL = .Range("A" & Rows.Count).End(xlUp).Row
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Range("A8:A" & DL) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=Range("B8:B" & DL) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=Range("C8:C" & DL) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange Range("A8:E" & DL)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

T = .Range("A8:E" & DL)
End With

For i = LBound(T, 1) To UBound(T, 1)  'création dictionnaire
    If Not IsNumeric(T(i, 3)) Then
        Parité = T(i, 3)
    Else
        Parité = IIf((T(i, 3) Mod 2) > 0, "I", "P")
    End If
    clé = T(i, 1) & "|" & T(i, 2) & "|" & Parité
    If Not Dico.Exists(clé) Then
        TT = Array(10000, 0, T(i, 4), T(i, 5))
    Else
        TT = Dico(clé)
    End If
    If IsNumeric(T(i, 3)) Then
        TT(0) = WorksheetFunction.Min(TT(0), T(i, 3))
        TT(1) = WorksheetFunction.Max(TT(1), T(i, 3))
    Else
        TT(0) = ""
        TT(1) = ""
    End If
    Dico(clé) = TT
Next


ReDim TFin(1 To Dico.Count, 1 To 5)
For Each clé In Dico.keys  ' report dictionnaire dans un tableau
    x = x + 1
    TT = Split(clé, "|")
    TFin(x, 1) = TT(0)
    TFin(x, 2) = TT(1)
    TT = Dico(clé)
    If IsNumeric(TT(0)) Then
        TFin(x, 3) = TT(0) & Chr(150) & TT(1)
    Else
        TFin(x, 3) = ""
    End If
    TFin(x, 4) = TT(2)
    TFin(x, 5) = TT(3)
Next

'copie du tableau dans une feuille
Worksheets("Feuil1").Range("A2").Resize(Dico.Count, 5) = TFin
End Sub