Copier et coller des lignes selon la valeur d'une cellule
senecartour
Messages postés
391
Statut
Membre
-
Mike-31 Messages postés 18405 Date d'inscription Statut Contributeur Dernière intervention -
Mike-31 Messages postés 18405 Date d'inscription Statut Contributeur Dernière intervention -
Bonjour à tous et bonne année 2015,
Je souhaite copier des lignes d'un onglet à un autre selon la valeur d'une cellule.
Autrement dit, à chaque fois que j'ai la valeur B dans la colonne A de la feuil1, je copie toute la ligne et la coller dans la feuil2.
J'ai crée une mlacro mais elle ne copie que la dernière ligne. Or moi, je souhaite copier toutes les lignes ayant la valeur B dans la colonne A.
Je vous joins mon fichier:https://www.cjoint.com/c/EAbaFh6QWql
Merci d'avance pour votre aide et bonne année 2015!!!!!
Partager son savoir est la meilleure façon d'apprendre!
Je souhaite copier des lignes d'un onglet à un autre selon la valeur d'une cellule.
Autrement dit, à chaque fois que j'ai la valeur B dans la colonne A de la feuil1, je copie toute la ligne et la coller dans la feuil2.
J'ai crée une mlacro mais elle ne copie que la dernière ligne. Or moi, je souhaite copier toutes les lignes ayant la valeur B dans la colonne A.
Je vous joins mon fichier:https://www.cjoint.com/c/EAbaFh6QWql
Merci d'avance pour votre aide et bonne année 2015!!!!!
Partager son savoir est la meilleure façon d'apprendre!
1 réponse
-
Bonjour,
Colle ce code dans un module et associe le à un bouton, les valeurs B de la colonne A seront collées sur la feuille nommée Feuil2 et les valeurs A sur la feuille Feuil3
Sub Transfert()
Dim LigFin As Long
LigFin = [A65000].End(xlUp).Row
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Feuil2").Cells.ClearContents
Sheets("Feuil3").Cells.ClearContents
Sheets("Feuil1").Range([A1], ["J"] & LigFin).AutoFilter Field:=1, Criteria1:="B"
If ActiveCell.Row = 1 Then
Exit Sub
Else
Range([A1], ["J"] & LigFin).Copy
Sheets("Feuil2").Select
[A1].PasteSpecial Paste:=xlPasteValues
[A2].Select
End If
Sheets("Feuil1").Select
Sheets("Feuil1").Range([A1], ["J"] & LigFin).AutoFilter Field:=1, Criteria1:="A"
If ActiveCell.Row = 1 Then
Exit Sub
Else
Sheets("Feuil3").Cells.ClearContents
Range([A1], ["J"] & LigFin).Copy
Sheets("Feuil3").Select
[A1].PasteSpecial Paste:=xlPasteValues
[A2].Select
End If
Sheets("Feuil1").Select
Application.CutCopyMode = False
[A1:G1].AutoFilter
Application.ScreenUpdating = True
MsgBox "Les données ont été ventilées", , "transfert terminé"
End Sub
A+
Mike-31
Une période d'échec est un moment rêvé pour semer les graines du savoir.
