XL 2019 EXCEL-VBA : Besoin de copier coller sous condition

mikado08

XLDnaute Nouveau
Bonjour à tous,

j'ai exploré plusieurs forum à la recherche des infos manquantes mais je ne suis pas assez callé en VBA pour adapter à mon besoin.

Je souhaite copier coller une ligne de A à O si dans la colonne A cela contient un "x" sur une autre feuille

1655461537440.png


qui va se copier avant mon Total HT.

je perd espoir de trouver un début de quelque chose tout seul :'(
 

fanch55

XLDnaute Barbatruc
Bonjour,
Je souhaite copier coller une ligne de A à O si dans la colonne A cela contient un "x" sur une autre feuille
Où sont les colonnes A à O ? un "x" dans la colonne A d' une autre feuille ; c'est quoi la référence à la ligne de la première feuille ?

Ce qui est fourni est plutôt "minimaliste" pour vous fournir une réponse correcte .
Auriez-vous une classeur exemple ?
 

mikado08

XLDnaute Nouveau
Bonjour,

Où sont les colonnes A à O ? un "x" dans la colonne A d' une autre feuille ; c'est quoi la référence à la ligne de la première feuille ?

Ce qui est fourni est plutôt "minimaliste" pour vous fournir une réponse correcte .
Auriez-vous une classeur exemple ?

voila en gros au lieu de rajouter des lignes a chaque fois
je voudrais avec une feuille "RUBRIQUES TYPE" pour la quand je met un "x" en A ca copie la ligne vers la feuille "Débours" mais avant le total HT et sans que ca écrase d'autre ligne qui serait déja la... c'est la que je bute
 

Pièces jointes

  • TRAME DEVIS BIS - Copie.xlsm
    92.1 KB · Affichages: 5

mikado08

XLDnaute Nouveau
VB:
Sub CopieDonnees()
Dim MotCle
Dim i As Byte
Dim C As Range
Dim F As String
Dim Ligne As Long
    'On définit les mots clés
    MotCle = Array("x", "X", "1")
    'On effectue la recherche de chaque mot clé dans la colonne A de la feuille "RUBRIQUES TYPE"
    For i = 0 To UBound(MotCle)
        Do
            Set C = Worksheets("RUBRIQUES TYPE").Columns(1).Find(MotCle(i), LookIn:=xlValues, lookat:=xlPart)
            'Si le mot clé est trouvé
            If Not C Is Nothing Then
                'On définit le nom de la feuille où sera effectuée la copie
                F = "Débours"
                With Worksheets(F)
                    'On définit la ligne où sera effectué le collage
                    Ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
                    'On effectue le copier / coller
                    C.EntireRow.Copy .Range("A" & Ligne)
                    'On supprime la ligne dans la sheet1
                    'C.EntireRow.Delete
                End With
            End If
        Loop While Not C Is Nothing
    Next i
End Sub

j'ai reprise un code qui appriorie devrait marché sur la partir C/C après la destination du collage dans la feuille cible à revoir... mais pourtant cela plante j'ai du faire une boucle infinie je ne vois pas ou
 
Dernière édition:

fanch55

XLDnaute Barbatruc
Mdp sur le VB du classeur fourni ...
Mais d'après l'analyse du code fourni,
Le find effectue une boucle sans fin car il retourne au début quand il a atteint la fin ...

Le code suivant devrait fonctionner:

VB:
Option Explicit
Sub CopieDonnees()
Dim MotCles     As Variant
Dim C           As Range
Dim F           As Worksheet
Dim C_Address   As String
Dim Ligne       As Long
    ' mots clés pour copier
    MotCles = Array("x", "X", "1")
    ' recherche des cellules non vides dans la colonne A de la feuille "RUBRIQUES TYPE"
    Set C = Worksheets("RUBRIQUES TYPE").Columns(1).Find("*", LookIn:=xlValues, lookat:=xlWhole)
    Do While Not C Is Nothing
        If C_Address = "" Then C_Address = C.Address
       ' Traitement si C est dans MotCles
        If UBound(Filter(MotCles, C, True, vbTextCompare)) >= 0 Then
            'nom de la feuille où sera effectuée la copie
            Set F = Worksheets("Débours")
            'ligne où sera effectué le collage
            Ligne = F.Range("A" & F.Rows.Count).End(xlUp).Row + 1
            'On effectue le copier / coller
            C.EntireRow.Copy F.Range("A" & Ligne)
            'On supprime la ligne dans la sheet1
            'C.EntireRow.Delete
        End If
        Set C = Worksheets("RUBRIQUES TYPE").Columns(1).FindNext(C)
        If C.Address = C_Address Then Set C = Nothing
    Loop
End Sub
 

Discussions similaires

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
302 236
Messages
2 001 687
Membres
215 256
dernier inscrit
Adso