Tri en masse Excel 2007

Option Explicit 
Option Base 1 

Sub Repartition() 
Dim DicoConcat As Object 
Dim concat(), Colonns(), TablDico() 
Dim DrLig As Long, i As Long, j As Long, Lig As Long, Col As Long 

Application.ScreenUpdating = False 
With Sheets("Feuil1") 
    DrLig = .Range("A" & Rows.Count).End(xlUp).Row 
    ReDim concat(DrLig) 
    ReDim Colonns(1 To DrLig, 1 To 6) 
    For i = 2 To DrLig 
        For j = 1 To 6 
            Colonns(i - 1, j) = .Cells(i, j) 
        Next j 
        concat(i - 1) = Colonns(i - 1, 5) & "_" & Colonns(i - 1, 6) 
    Next i 
End With 
Set DicoConcat = CreateObject("Scripting.Dictionary") 
For i = LBound(concat) To UBound(concat) 
    DicoConcat(concat(i)) = "" 
Next i 
If DicoConcat.Count + ThisWorkbook.Worksheets.Count >= 250 Then 
    MsgBox "Votre classeur va dépasser les 250 feuilles. Fractionnez le au préalable." 
    Exit Sub 
End If 
TablDico = DicoConcat.keys 
'Si vous souhaitez tester si la feuille a déjà été créée 
'enlevez les apostrophes en début des lignes suivantes 
For i = 1 To UBound(TablDico) - 1 
'    If FeuilleExiste(TablDico(i)) = False Then 
        ThisWorkbook.Worksheets.Add 
        With ActiveSheet 
            .Name = TablDico(i) 
            .Range("A1") = "Fournisseur" 
            .Range("B1") = "Ref" 
            .Range("C1") = "Description" 
            .Range("D1") = "Prix" 
            .Range("E1") = "Famille" 
            .Range("F1") = "Sous famille" 
            For j = 1 To UBound(concat) 
                If concat(j) = TablDico(i) Then 
                    Lig = .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row 
                    For Col = 1 To 6 
                        .Cells(Lig, Col) = Colonns(j, Col) 
                    Next 
                End If 
            Next j 
        End With 
'    Else 
'        With Sheets(concat) 
'            .Cells.Clear 
'        End With 
'    End If 
Next i 
Sheets("Feuil1").Select 

End Sub 

Function FeuilleExiste(NomFeuille) As Boolean 
    Dim f As Object 
    On Error Resume Next 
    Set f = Sheets(NomFeuille) 
    If Err = 0 Then FeuilleExiste = True 
    Set f = Nothing 
End Function

For i = 1 To UBound(TablDico) - 1

For i = 0 To UBound(TablDico) - 1

Option Explicit
Option Base 1

Sub Repartition()
Dim DicoConcat As Object
Dim concat(), Colonns(), TablDico()
Dim DrLig As Long, i As Long, j As Long, Lig As Long, Col As Long

Application.ScreenUpdating = False
With Sheets("Feuil1")
    DrLig = .Range("A" & Rows.Count).End(xlUp).Row
    ReDim concat(DrLig)
    ReDim Colonns(1 To DrLig, 1 To 6)
    For i = 2 To DrLig
        For j = 1 To 6
            Colonns(i - 1, j) = .Cells(i, j)
        Next j
        concat(i - 1) = Colonns(i - 1, 5) & "_" & Colonns(i - 1, 6)
    Next i
End With
Set DicoConcat = CreateObject("Scripting.Dictionary")
For i = LBound(concat) To UBound(concat)
    DicoConcat(concat(i)) = ""
Next i
If DicoConcat.Count + ThisWorkbook.Worksheets.Count >= 250 Then
    MsgBox "Votre classeur va dépasser les 250 feuilles. Fractionnez le au préalable."
    Exit Sub
End If
TablDico = DicoConcat.keys
'Si vous souhaitez tester si la feuille a déjà été créée
'enlevez les apostrophes en début des lignes suivantes
For i = 0 To UBound(TablDico) - 1
'    If FeuilleExiste(TablDico(i)) = False Then
        ThisWorkbook.Worksheets.Add
        With ActiveSheet
            .Name = TablDico(i)
            .Range("A1") = "Fournisseur"
            .Range("B1") = "Ref"
            .Range("C1") = "Description"
            .Range("D1") = "Prix"
            .Range("E1") = "Famille"
            .Range("F1") = "Sous famille"
            For j = 1 To UBound(concat)
                If concat(j) = TablDico(i) Then
                    Lig = .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
                    For Col = 1 To 6
                        .Cells(Lig, Col) = Colonns(j, Col)
                    Next
                End If
            Next j
        End With
'    Else
'        With Sheets(concat)
'            .Cells.Clear
'        End With
'    End If
Next i
Sheets("Feuil1").Select

End Sub

Function FeuilleExiste(NomFeuille) As Boolean
    Dim f As Object
    On Error Resume Next
    Set f = Sheets(NomFeuille)
    If Err = 0 Then FeuilleExiste = True
    Set f = Nothing
End Function