Tri et découpe

Sub test()
Dim DFeuille As Object
Dim i&, F As Worksheet, FTst As Worksheet
Set DFeuille = CreateObject("Scripting.dictionary")
Set F = Sheets("Base de données")

Application.ScreenUpdating = False

For i = 2 To F.Cells(F.Rows.Count, 1).End(3).Row
    On Error Resume Next
    Set FTst = Sheets(F.Cells(i, 6).Value)
    If Err Then
        Err.Clear
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = F.Cells(i, 6).Value
        Set FTst = Sheets(F.Cells(i, 6).Value)
        F.Range(F.Cells(1, 1), F.Cells(1, 11)).Copy FTst.Cells(1, 1)
        DFeuille(F.Cells(i, 6).Value) = ""
    End If
    If Not DFeuille.exists(FTst.Name) Then
        FTst.Range(FTst.Cells(2, 1), FTst.Cells(FTst.Rows.Count, 1).End(3)(1, 11)).ClearContents
        DFeuille(FTst.Name) = ""
    End If
    F.Range(F.Cells(i, 1), F.Cells(i, 11)).Copy FTst.Cells(FTst.Rows.Count, 1).End(3)(2)
    Set FTst = Nothing
Next i

F.Activate
End Sub