Copiée une ligne dans une des feuilles sous condition

Bonjour à toutes et tous,

Voilà je suis le décor: je suis une bille en VBA ...

Cependant j'ai créé grâce à l'enregistreur de macro ma macro toute simple; c'est à dire sélectionner une ligne contenant toutes mes infos et la copier coller dans un tableau récapitulatif tout en tenant compte de devoir copier coller à la ligne à chaque fois.

Cependant, j'aimerais mettre une condition à cette macro; c'est à dire que (par exemple) si en A1 de ma ligne est marqué: chien, chat, autre, ... alors ma ligne va se copier dans la feuille correspondant à ce mot (chat, chien, autre, ...)

Donc comment puis je faire cela?

Voilà la macro:

Sub Valider()

    Sheets("Base de données").Select

    Rows("6:6").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
    Sheets("Fiche ").Select

    Rows("150:150").Select
    Selection.Copy
    Sheets("Base de données").Select
    Range("A6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Fiche ").Select

    Range("A1").Select
    Application.CutCopyMode = False
    Selection.ClearContents
End Sub

Cordialement

Bonjour et bienvenue

On sous-entend que tous les noms des onglets existent

Place un bouton sur la feuille qui contient les données à dispatcher et affecte-lui ce code

Sub Copier()
Dim i As Integer, lg As Integer
Dim Feuille As String
Application.ScreenUpdating = False

For i = 2 To Sheets.Count 'La feuille qui contient les données doit se trouver en 1ère position
Sheets(i).Range("A2:C65536").ClearContents 'Plage à adapter
Next i

For i = 2 To Range("A65535").End(xlUp).Row 'Les données débutent en ligne 2 et en colonne A
Feuille = Cells(i, 1).Value '1 pour la colonne A
lg = Sheets(Feuille).Range("A65535").End(xlUp).Row + 1
Rows(i).Copy Sheets(Feuille).Range("A" & lg) 'Copie à partir de la colonne A
Next i

End Sub

Si tu n'y arrives pas, merci de joindre un fichier.

Amicalement

Nad

Bonjour, désolé du retard pour la réponse mais je n'ai pu continuer sur ma macro et je reprend dessus que maintenant.

j'ai expérimenté plusieurs choses mais à chaque fois des problèmes se pose notamment:

Fusion des lignes (voir excel dans le lien)

Le lien est un exemple car je ne peux diffuser mon travail donc j'ai essayé d'adapter ...

Pour mémoire, j'avais la macro suivante, mais lorsqu'elle s'éxecute, pour la colonne C, je n'ai besoin de compter les lignes que de C2 à C10 or je n'arrive pas à restreindre et cela me compte tout

Sub Copier()

Dim c As Range

Dim ligneajout As Long

Application.ScreenUpdating = False

With Worksheets("Feuil1")

For Each c In .Range("C2:C" & .Range("C" & Rows.Count).End(xlUp).Row)

If Not IsEmpty(c) Then

ligneajout = Worksheets("BD").Range("A" & Rows.Count).End(xlUp).Offset(1).Row

c.EntireRow.Copy

Worksheets("BD").Range("A" & ligneajout).PasteSpecial xlPasteValues

End If

Next c

If Range("G1") = "m" Then

For Each c In .Range("C2:C" & .Range("C" & Rows.Count).End(xlUp).Row)

If Not IsEmpty(c) Then

ligneajout = Worksheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Offset(1).Row

c.EntireRow.Copy

Worksheets("Feuil2").Range("A" & ligneajout).PasteSpecial xlPasteValues

End If

Next c

ElseIf Range("g1") = "embout" Then

For Each c In .Range("C2:C" & .Range("C" & Rows.Count).End(xlUp).Row)

If Not IsEmpty(c) Then

ligneajout = Worksheets("Feuil3").Range("A" & Rows.Count).End(xlUp).Offset(1).Row

c.EntireRow.Copy

Worksheets("Feuil3").Range("A" & ligneajout).PasteSpecial xlPasteValues

End If

Next c

ElseIf Range("g1") = "D" Then

For Each c In .Range("C2:C" & .Range("C" & Rows.Count).End(xlUp).Row)

If Not IsEmpty(c) Then

ligneajout = Worksheets("Feuil4").Range("A" & Rows.Count).End(xlUp).Offset(1).Row

c.EntireRow.Copy

Worksheets("Feuil4").Range("A" & ligneajout).PasteSpecial xlPasteValues

End If

Next c

End If

End With

Application.CutCopyMode = False

Application.ScreenUpdating = True