Copier une ligne en fonction de la valeur d'une cellule

- - Dernière réponse :  Vdel - 3 juil. 2019 à 11:37
Bonjour,

Malgré mes recherches. Je n'ai pas trouvé ce que je voulais et vous sollicite donc aujourd'hui.

Voici mon problème :
Je souhaiterais copier les lignes de ma feuille 1 sur la feuille 2 à chaque fois que la valeur "x" apparaît dans la colonne A de la feuille 1.

Je suis débutant en VBA et sèche un peu...

Merci par avance de votre aide

Configuration: Android / Opera Next 52.3.2517.140547
Afficher la suite 

3 réponses

Meilleure réponse
Messages postés
1977
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
23 juillet 2019
220
1
Merci
Bonjour,

Est-ce bien une copie de la ligne comportant un "x" en colonne A ou bien déplacer cette ligne dans la feuille 2, dans ce cas elle serait supprimée de la feuille 1?

En attendant voici un exemple avec la copie
https://mon-partage.fr/f/0d9yd7ss/

le code utilisé:
Option Compare Text
Option Explicit

Sub Recopie()
    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("Feuil1")
    Set f2 = Sheets("Feuil2")
    
    DerLig_f1 = f1.[A100000].End(xlUp).Row
    DerCol_f1 = [xfd1].End(xlToLeft).Column
    Derlig_f2 = f2.[A10000].End(xlUp).Row + 1
    For i = 1 To DerLig_f1
        If f1.Cells(i, "A") = "x" Then
            f1.Range(Cells(i, "B"), 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
End Sub


Cdlt

Dire « Merci » 1

Heureux de vous avoir aidé ! Vous nous appréciez ? Donnez votre avis sur nous ! Evaluez CommentCaMarche

CCM 59152 internautes nous ont dit merci ce mois-ci

Commenter la réponse de Frenchie83
Messages postés
1977
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
23 juillet 2019
220
1
Merci
Ne connaissant pas la structure de votre fichier, j'ai déterminé le nombre de colonne à recopier calqué sur la première ligne -1 de la feuille 1(la colonne A n'est pas comptabilisée, vu qu'il n'y a que des "X").
C'est la ligne suivante:
DerCol_f1 = [xfd1].End(xlToLeft).Column
qui détermine ce nombre de colonnes. Vous pouvez fixer ce nombre par exemple à 10 en remplaçant la ligne précédente par DerCol_f1 =10, sinon dites-moi quelle est la ligne eà prendre en considération.

Dire « Merci » 1

Heureux de vous avoir aidé ! Vous nous appréciez ? Donnez votre avis sur nous ! Evaluez CommentCaMarche

CCM 59152 internautes nous ont dit merci ce mois-ci

C'est parfait, le code fonctionne exactement comme je le voulais. Un grand merci pour m'avoir aidé !! Bonne journée
Commenter la réponse de Frenchie83
0
Merci
Bonjour,

Merci de prendre le temps de me répondre.

L'idée est d'envoyer la ligne contenant un "x" de la colonne A, feuille 1 à la feuille 2 avec l'utilisation d'un bouton.

Si il est possible de supprimer directement la ligne d'origine (feuille 1), je suis preneur.

Le soucis est qu'il faudrait que les lignes envoyés dans la feuille 2 s'incrémentent au fil des utilisations du bouton.

Merci par avance
Frenchie83
Messages postés
1977
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
23 juillet 2019
220 -
Voilà avec suppression des lignes marquées d'un "x"

https://mon-partage.fr/f/wZhmEYsI/

Le code
Option Compare Text
Option Explicit

Sub Recopie()
    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("Feuil1")
    Set f2 = Sheets("Feuil2")
    
    DerLig_f1 = f1.[A100000].End(xlUp).Row
    DerCol_f1 = [xfd1].End(xlToLeft).Column
    Derlig_f2 = f2.[A10000].End(xlUp).Row + 1
    For i = DerLig_f1 To 1 Step -1
        If f1.Cells(i, "A") = "x" Then
            f1.Range(Cells(i, "B"), Cells(i, DerCol_f1)).Copy Destination:=f2.Cells(Derlig_f2, "A")
            f1.Range(Cells(i, "A"), Cells(i, DerCol_f1)).EntireRow.Delete
            Derlig_f2 = Derlig_f2 + 1
        End If
    Next i
    
    Set f1 = Nothing
    Set f2 = Nothing
End Sub


Cdlt
> Frenchie83
Messages postés
1977
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
23 juillet 2019
-
C'est exactement ce que je cherchais ! Vraiment super !

Juste une petite question :
La procédure efface bien toute la ligne mais lorsqu'il colle la ligne dans la feuille 2. Seules 8 cellules sont collées.
Commenter la réponse de Vdel