Copie de ligne sous condition

Bonjour à tous!

Je vous sollicite aujourd'hui car je suis confronté à un petit problème.

Je souhaite à partir d'un tableau source, copier certaines lignes de ce tableau vers d'autres onglets en fonction de certaines conditions.

Dans le fichier joint, je souhaite copier dans un premier onglet les lignes qui contiennent "L01" et "L02" dans la 8ème colonne; dans un autre onglet, je souhaite copier celles qui contiennent "L03" et "L04".

J'ai pondu ça à l'aide de ce que j'ai trouvé sur le forum et de mes maigres connaissances en la matière mais je n'arrive malheureusement pas à mes fins.

Sub CopieLigne()

Dim MotsCh
Dim i As Byte
Dim C As Range
Dim F As String
Dim Ligne As Long

MotsCh = Array("L01", "L02")

For i = 0 To UBound(MotsCh)
    Do
        Set C = Worksheets("Feuil1").Columns(8).Find(MotsCh(i), LookIn:=xlValues, lookat:=xlPart)

        If Not C Is Nothing Then

        F = "L01 L02" & (i + 2)
        With Worksheets(F)

            Ligne = .Range("F" & Rows.Count).End(xlUp).Row + 1

            C.EntireRow.Copy .Range("A" & Ligne)

        End With
    End If
Loop While Not C Is Nothing
Next i

End Sub

Je suis preneur de toute solution!

Merci d'avance !

Bonne fin de journée à tous

5classeur1.xlsm (14.26 Ko)

Bonjour,

Ci-joint ton fichier ...

En espèrant que cela t'aide ...

Bonjour,

Une autre piste :

Sub CopieLigne()

    Dim Plage As Range
    Dim Cel As Range
    Dim TblFeuille
    Dim MotsCh
    Dim I As Integer
    Dim J As Integer
    Dim Ligne As Long
    Dim Adr As String

    'noms des feuilles
    TblFeuille = Array("L01 L02", "L03 L04")

    'défini la plage sur la colonne "F" de la feuille "Feuil1" à partir de F2
    With Worksheets("Feuil1"): Set Plage = .Range(.Cells(2, 8), .Cells(.Rows.Count, 8).End(xlUp)): End With

    For I = 0 To UBound(TblFeuille)

        'splite le nom de la feuille pour en récupérer les deux parties...
        MotsCh = Split(TblFeuille(I), " ")

        'puis boucle pour la recherche...
        For J = 0 To UBound(MotsCh)

            Set Cel = Plage.Find(MotsCh(J), , xlValues, xlWhole)

            If Not Cel Is Nothing Then

                Adr = Cel.Address

                Do

                    With Worksheets(TblFeuille(I))

                        Ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1

                        Cel.EntireRow.Copy .Range("A" & Ligne)

                    End With

                    Set Cel = Plage.FindNext(Cel)

                Loop While Cel.Address <> Adr

            End If

    Next J, I

End Sub

Bonsoir,

Une proposition à étudier.

Cdlt.

9classeur1.xlsm (27.40 Ko)
Option Explicit

Public Sub FilterAnCopyData()
Dim ws As Worksheet
Dim lo As ListObject
Dim rng As Range, rStart As Range

    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Données" Then
            Set lo = ws.ListObjects(1)
            If Not lo.DataBodyRange Is Nothing Then lo.DataBodyRange.Delete
        End If
    Next ws

    Set lo = Worksheets("Données").ListObjects(1)

    'L01 - L02
    lo.Range.AutoFilter Field:=8, Criteria1:="=L01", Operator:=xlOr, Criteria2:="=L02"
    With lo.AutoFilter.Range
        On Error Resume Next
        Set rng = .Offset(1).Resize(lo.ListRows.Count, lo.ListColumns.Count) _
                  .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
    End With
    If rng Is Nothing Then
        MsgBox "Il n'y a pas de données à copier.", vbInformation
    Else
        Set rStart = Worksheets("L01 L02").ListObjects(1).InsertRowRange.Cells(1)
        rng.Copy
        rStart.PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End If

    'L03 - L04
    lo.Range.AutoFilter Field:=8, Criteria1:="=L03", Operator:=xlOr, Criteria2:="=L04"
    With lo.AutoFilter.Range
        On Error Resume Next
        Set rng = .Offset(1).Resize(lo.ListRows.Count, lo.ListColumns.Count) _
                  .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
    End With
    If rng Is Nothing Then
        MsgBox "Il n'y a pas de données à copier.", vbInformation
    Else
        Set rStart = Worksheets("L03 L04").ListObjects(1).InsertRowRange.Cells(1)
        rng.Copy
        rStart.PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End If
    lo.Range.AutoFilter Field:=8

    Set rStart = Nothing: Set rng = Nothing
    Set lo = Nothing

End Sub

Bonjour, merci à tous pour votre aide! J'ai réussi à faire ce que je voulais

Bonjour, merci à tous pour votre aide! J'ai réussi à faire ce que je voulais

Bonjour,

Avec une avalanche de propositions ...Content que tu aies pu résoudre ton problème ...

Merci ... pour tes remerciements à la Communauté ...

Rechercher des sujets similaires à "copie ligne condition"