Transférer données vers une autre page avec condition

Bonjour à toutes et tous,

Je viens de débuter dans l'univers des macros, depuis quelques jours :) univers que je trouve très intéressant d'ailleurs.

J'aurais besoin de petits conseils car je n'arrive pas à faire exactement ce que je veux.

J'ai un tableau excel avec une colonne "Statut" et je voudrais transférer sur une autre feuille (qui idéalement serait toujours la même) les données d'une ligne entière SI dans la cellule "statut" une certaine donnée apparaît.

J'ai donc créé un bouton avec une liste déroulante pour sélectionner le statut en question.

Et en suivant des tuto (pardonnez-moi le niveau débutant) j'ai inséré les codes suivants:

Private Sub btmExtraction_Click()
'déclaration des Variables
Dim Statut As Range
Dim ListeStatut As Range
Dim NbLignes As Long
Dim LigneActive As Long

'Affectation des variables
Set ListeStatut = Feuil1.Range("A2", Feuil1.Range("A1").End(xlDown))
NbLignes = ListeStatut.Rows.Count
LigneActive = 0

'On insère une nouvelle feuille.
Sheets.Add
Feuil1.Range("A1").EntireRow.Cut ActiveCell
Range("A2").Select

'On boucle chaque statut se trouvant dans la liste
For Each Statut In ListeStatut

'On se décale d'une ligne vers le bas
LigneActive = LigneActive + 1
'On recherche le statut qui a été saisie dans la liste déroulante
If Statut.Offset(0, 9).Value = Me.cbostatut.Value Then
'Si le statut est trouvé, on récupère la ligne
Statut.EntireRow.Cut ActiveCell
ActiveCell.Offset(1, 0).Select
End If
Next Statut

End Sub

Cela fonctionne pas complètement comme je le souhaite car:

* ça ajoute systématiquement une nouvelle page

* ça renvoie les lignes une par une sur des pages différentes et il faut actionner le bouton plusieurs fois.

Pouvez-vous m'aider s'il vous plaît?

Je suis désolée je débute et mon vocabulaire n'est peut-être pas correct^^

Merci par avance

Bonjour,

Je n'ai pas parfaitement compris mais voici un essai, avec suppression des lignes qui ne me semblaient pas fondamentales

Private Sub btmExtraction_Click()

Dim f1 as worksheet, fstatut as worksheet
Dim nbl As Long, i As Long, n&
Dim vcherchee$

vcherchee = Me.cbostatut.Value 'valeur combobox (statut inspecté)
Set f1 = Sheets("Feuil1") 'feuille 1 <<< adapter si besoin

with f1 'avec feuille 1
    nbl = .Range("A" & .rows.count).End(xlup).row 'dernière ligne non vide
    If application.countif(.Range("I2:I" & nbl), vcherchee) > 0 Then ' si vcherchee existe en colonne I
        set fstatut = Sheets.Add(after:=f1) 'ajout d'une feuille après f1 affectant la variable fstatut
        fstatut.name = vcherchee 'nom nvl feuille = statut inspecté
        n = 2 'initialisation n
        For i = 2 to nbl 'pour chaque ligne du tableau statut
            If .cells(i, 9).Value = vcherchee Then 'si la cellule vaut vcherchee
                .range("A" & i & ":I" & i).cut fstatut.range("A" & n) 'couper/coller la ligne i de f1 à la ligne n de fstatut
                n = n + 1 'incrémentation de n
            End If
        Next cell
    End If
End Wtih

End Sub

Cdlt,

Merci de m'avoir répondu

J'ai essayé en adaptant mais cela ne fonctionne pas.

Voici mon tableau en question (vierge de macro).

Je ne sais pas q'il y a un moyen plus simple de faire , j'avais envisagé un bouton car je ne connais pas du tout l'étendue des possibilités.

Pour faire simple, je voudrais que lorsque dans la colonne J "Statut" le choix "ex reçu" est sélectionné , l'intégralité de la ligne se transfère sur une autre page qui serait comme une archive.

Il y aurait donc la feuille principale avec le tableau excel, la feuille de mes listes déroulantes et une feuille archive qui contiendrait les lignes du tableau principal où "ex reçu" aurait été sélectionné en colonne J (Statut).

C'est assez compliqué à expliquer, désolée encore.

Pouvez-vous m'expliquer comment procéder?

Merci beaucoup.

On en est pas loin vous savez.

Mais il faut que vous clarifiez votre besoin. Vous testez la colonne 10. Vous exportez les valeurs mais vous voulez vraiment couper/coller, ou copier/coller ou prendre uniquement les valeurs.

Est-ce qu'il faut créer une feuille pour chaque Statut ou est-ce qu'il y aura une feuille archive sur laquelle on collera les données à la suite ?

Ou y a-t-il une erreur (quelle ligne de code) ? Et quel message d'erreur y a-t-il ? Merci de me le dire à chaque fois sinon, travaillant à l'aveugle, je ne peux pas comprendre grand-chose.

Et bien sûr, la macro pourra être affectée à un bouton.

Oui, je teste la colonne 10. Lorsque "EX reçu" apparaît dans cette colonne , j'aimerais couper la/les ligne(s) entière(s) et la/les coller sur une autre page.

C'est cela les données seraient collées à la suite sur l'autre page, il n'y aurait qu'une seule page d'archive pour toutes les lignes considérées comme "finalisées" avec le statut "EX reçu".

Les codes semblent pour la colonne I, mais la colonne statut est la J, mais en adaptant cela ne fonctionne pas non plus.

Bonjour,

En effet, je n'avais pas mis la bonne colonne. Voici un essai mais il faudra bien contrôler les noms des feuilles et notamment celui de Archive qui devra être créée au préalable.

Private Sub btmExtraction_Click()

Dim f1 as worksheet, farchive as worksheet
Dim nbl&, i&, n&
Dim vcherchee$

vcherchee = Me.cbostatut.Value 'valeur combobox (statut inspecté)
Set f1 = Sheets("Feuil1") 'feuille 1 <<< adapter si besoin
Set farchive = Sheets("Archive") '<<< adapter si besoin, doit exister

application.screenupdating = false

with f1 'avec feuille 1
    nbl = .Range("A" & .rows.count).End(xlup).row 'dernière ligne non vide de f1
    If application.countif(.Range("J2:J" & nbl), vcherchee) > 0 Then ' si vcherchee existe en colonne I
        n = farchive.cells(farchive.rows.count, 1).end(xlup).row 'dernière ligne non vide de archive
        For i = 2 to nbl 'pour chaque ligne du tableau statut
            If .cells(i, 10).Value = vcherchee Then 'si la cellule vaut vcherchee
                n = n + 1 'incrémentation de n
                .range("A" & i & ":J" & i).cut farchive.range("A" & n) 'couper/coller la ligne i de f1 à la ligne n de farchive
                '.range("A" & i & ":J" & i).delete shift:=xlshiftup
            End If
        Next i
    else
        msgbox "La valeur " & vcherchee & " n'existe pas dans la zone de recherche" 'sinon, msg echec
    End If
End With

application.screenupdating = true

set farchive = nothing: set f1 = nothing

End Sub

On s'en approche maintenant .

Cdlt,

Merci pour votre aide!

J'ai créé le bouton d'extraction auquel j'ai attribué la macro, j'ai aussi créé la feuille archive.

Mais lorsque je teste, ceci s'affiche:

Private Sub Btnextraction_Click()

J'ai édité le code

Je ne comprends pas

J'ai modifié le code sur mon précédent commentaire (en remplaçant le next cell par next i).

Ha d'accord.

Un grand merci!

J'ai refait le test, ça fonctionne :) Par contre j'aimerais savoir s'il y a possibilité que les lignes se suppriment du premier tableau quand elles "migrent sur l'onglet archive".

Super ! Regardez le code, j'ai prévu une ligne à cet effet, que j'ai laissée en commentaire, il faut juste enlever l'apostrophe.

'.range("A" & i & ":J" & i).delete shift:=xlshiftup

devient

.range("A" & i & ":J" & i).delete shift:=xlshiftup

J'ai fait le test, mais lorsque j'actionne le bouton commande il me dit qu'il y a une erreur sur cette ligne en question justement, comme quoi la méthode à échoué.

.Range("A" & i & ":J" & i).Delete shift:=xlShiftUp

Comme ça alors ?

Private Sub btmExtraction_Click()

Dim f1 as worksheet, farchive as worksheet
Dim rsupp as range
Dim nbl&, i&, n&
Dim vcherchee$

vcherchee = Me.cbostatut.Value 'valeur combobox (statut inspecté)
Set f1 = Sheets("Feuil1") 'feuille 1 <<< adapter si besoin
Set farchive = Sheets("Archive") '<<< adapter si besoin, doit exister

application.screenupdating = false

with f1 'avec feuille 1
    nbl = .Range("A" & .rows.count).End(xlup).row 'dernière ligne non vide de f1
    If application.countif(.Range("J2:J" & nbl), vcherchee) > 0 Then ' si vcherchee existe en colonne I
        n = farchive.cells(farchive.rows.count, 1).end(xlup).row 'dernière ligne non vide de archive
        For i = 2 to nbl 'pour chaque ligne du tableau statut
            If .cells(i, 10).Value = vcherchee Then 'si la cellule vaut vcherchee
                n = n + 1 'incrémentation de n
                .range("A" & i & ":J" & i).cut farchive.range("A" & n) 'couper/coller la ligne i de f1 à la ligne n de farchive
                if rsupp is nothing then set rsupp = .range("A" & i & ":J" & i)
                set rsupp = union(rsupp, .range("A" & i & ":J" & i))
            End If
        Next i
        rsupp.delete shift:=xlshiftup
    else
        msgbox "La valeur " & vcherchee & " n'existe pas dans la zone de recherche" 'sinon, msg echec
    End If
End With

application.screenupdating = true

set rsupp = nothing: set farchive = nothing: set f1 = nothing

End Sub

Cdlt,

Cette fois quand j'essaye j'ai ce message :

Pour cette ligne:

rsupp.Delete shift:=xlShiftUp

Je viens de regarder votre fichier... Je ne savais pas que vous aviez un tableau structuré. Il faut annexer à votre tableau les colonnes A et B !

Alors dernière, et j'espère ultime, mise à jour :

Private Sub btmExtraction_Click()

Dim farchive as worksheet
Dim rsupp as range
Dim nbl&, i&, n&
Dim vcherchee$

vcherchee = Me.cbostatut.Value 'valeur combobox (statut inspecté)
Set farchive = Sheets("Archive") '<<< adapter si besoin, doit exister
nbl = range("Tableau2").rows.count 'dernière ligne non vide de f1

application.screenupdating = false

If application.countif(Range("Tableau2[STATUT]"), vcherchee) > 0 Then ' si vcherchee existe en colonne I
    n = farchive.cells(farchive.rows.count, 1).end(xlup).row 'dernière ligne non vide de archive
    For i = 1 to nbl 'pour chaque ligne du tableau statut
        If Range("Tableau2[STATUT]")(i).Value = vcherchee Then 'si la cellule vaut vcherchee
            n = n + 1 'incrémentation de n
            range("Tableau2").rows(i).cut farchive.range("A" & n) 'couper/coller la ligne i de f1 à la ligne n de farchive
            if rsupp is nothing then set rsupp = range("Tableau2").rows(i)
            set rsupp = union(rsupp, range("Tableau2").rows(i))
        End If
    Next i
    if not rsupp is nothing then rsupp.delete shift:=xlshiftup
else
    msgbox "La valeur " & vcherchee & " n'existe pas dans la zone de recherche" 'sinon, msg echec
End If

application.screenupdating = true

set rsupp = nothing: set farchive = nothing: set f1 = nothing

End Sub

Il faut aussi supprimer l'espace de l'en-tête "STATUT " et d'ailleurs tous les éventuels espaces indésirables dans les titres.

Par ailleurs, renommer votre tableau avec un nom bref et clair pourrait être judicieux. Il faudrait alors adapter le code (ctrl + F, remplacer Tableau2 par NouveauNom). Et si possible, il faut que vous évitiez les lignes vides dans votre tableau, ou que vous essayiez d'en avoir le moins possible.

Bonne soirée,

J'ai suivi tous vos conseils et maintenant tout fonctionne!

Merci beaucoup, ce tableau va beaucoup m'aider.

Bon weekend

Je suis content que ça fonctionne (enfin, j'ai envie de dire) !

Merci et très bon week-end à vous aussi !