Copier coller ligne dans différents onglet suivant valeur

Bonjour,

J'ai essayé plusieurs choses, mais avec la fatigue je fait n'importe quoi et cela ne mène à rien...
Voici ce que je cherche à faire :

J'ai un onglet donnée que je voudrais répartir dans différents onglets en fonction de la valeur de la colonne A.
Petite particularité, le premier cas de figure comprends 2 valeurs (A et A A).

Je vous remercie par avance et vous souhaite une agréable journée.

Olivier

Help

J'ai un début de réponse :

Sub Dispatch()

Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f1 As Long, Derlig_f2 As Long, DerCol_f1 As Long
    Dim i As Long

    Application.ScreenUpdating = False
    Set f1 = Sheets("Données")
    Set f2 = Sheets("A - A A")

    DerLig_f1 = f1.[A100000].End(xlUp).Row
    DerCol_f1 = 11
    Derlig_f2 = f2.[A10000].End(xlUp).Row + 1
    For i = 1 To DerLig_f1
        If f1.Cells(i, "A") = "A" Then
            f1.Range(Cells(i, "A"), Cells(i, DerCol_f1)).Copy Destination:=f2.Cells(Derlig_f2, "A")
            Derlig_f2 = Derlig_f2 + 1
        ElseIf f1.Cells(i, "A") = "A A" Then
            f1.Range(Cells(i, "A"), Cells(i, DerCol_f1)).Copy Destination:=f2.Cells(Derlig_f2, "A")
            Derlig_f2 = Derlig_f2 + 1
        End If
    Next i

    Set f1 = Nothing
    Set f2 = Nothing

Application.ScreenUpdating = True

End Sub

Pour ceux que cela interesse la solution ci-dessus fonctionne avec une succession de

ElseIf

Et terminer par un

Else

Pour y mettre tout ce qui rentre pas dans la succession de filtres.

Bonjour Olivier

Je pens que tu t'es paniqué un peu vite, puisque tu as trouvé la solution tout seul.

Code :

Sub Dispatch()

Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f1 As Long, Derlig_f2 As Long, DerCol_f1 As Long
    Dim i As Long

    Application.ScreenUpdating = False
    Set f1 = Sheets("Données")
    Set f2 = Sheets("A - A A")
    Set f3 = Sheets("B")
    Set f4 = Sheets("C")
    Set f5 = Sheets("D")
    Set f6 = Sheets("Autres")
    DerLig_f1 = f1.[A100000].End(xlUp).Row
    DerCol_f1 = 11
    Derlig_f2 = f2.[A10000].End(xlUp).Row + 1
    Derlig_f3 = f3.[A10000].End(xlUp).Row + 1
    Derlig_f4 = f4.[A10000].End(xlUp).Row + 1
    Derlig_f5 = f5.[A10000].End(xlUp).Row + 1
    Derlig_f6 = f6.[A10000].End(xlUp).Row + 1
    For i = 1 To DerLig_f1
        If f1.Cells(i, "A") = "A" Or f1.Cells(i, "A") = "A A" Then
            f1.Range(Cells(i, "A"), Cells(i, DerCol_f1)).Copy Destination:=f2.Cells(Derlig_f2, "A")
            Derlig_f2 = Derlig_f2 + 1
        ElseIf f1.Cells(i, "A") = "B" Then
            f1.Range(Cells(i, "A"), Cells(i, DerCol_f1)).Copy Destination:=f3.Cells(Derlig_f3, "A")
            Derlig_f3 = Derlig_f3 + 1
        ElseIf f1.Cells(i, "A") = "C" Then
            f1.Range(Cells(i, "A"), Cells(i, DerCol_f1)).Copy Destination:=f4.Cells(Derlig_f4, "A")
            Derlig_f4 = Derlig_f4 + 1
        ElseIf f1.Cells(i, "A") = "D" Then
            f1.Range(Cells(i, "A"), Cells(i, DerCol_f1)).Copy Destination:=f5.Cells(Derlig_f5, "A")
            Derlig_f5 = Derlig_f5 + 1
        Else
            f1.Range(Cells(i, "A"), Cells(i, DerCol_f1)).Copy Destination:=f6.Cells(Derlig_f6, "A")
            Derlig_f6 = Derlig_f6 + 1
        End If
    Next i

    Set f1 = Nothing
    Set f2 = Nothing
    Set f3 = Nothing
    Set f4 = Nothing
    Set f5 = Nothing
    Set f6 = Nothing
Application.ScreenUpdating = True

End Sub

Je pense que c'est ce que tu as fait

Bonne fin de journée

Oui c'est ce que j'ai fait :-)

Pour la peine que tu t'es donnée je te donne la validation du sujet.

Merci à toi :-)