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
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.
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é ...