CC d'une feuille à une autre avec un critére

Hello tout le monde

Je requiert votre aide pour de la programmation dans une macro VBA. Voici mon idée:

Je souhaite copier les données d'une feuille et les coller dans une autre feuille. Mais, je souhaite appliquer un critère a cela, c'est à dire que si le mot "Oui" apparaît dans la cellule D(i) (i variant de la première ligne jusque la dernière ligne), alors je souhaite copier l'intégralité (c'est à dire de la première cellule de la ligne correspondant jusqu'à la dernière non vide) de la ligne. Sinon je passe à la ligne suivante.

Mon code/idée est le suivant:

Option Explicit

'Private Sub CommandButton1_Click()
Sub antgrandj()

Dim i As Integer
Dim rng_feuil1 As Range
Dim rng_project As Range

Set rng_feuil1 = Worksheets("Feuil1").Range("C10")

With Worksheets("project")
    .Range("A8:L" & .Range("L50").End(xlUp).Row).ClearContents
    Set rng_project = .Range("A8")

    For i = 0 To Worksheets("Feuil1").Columns(3).Find("*", , , , , xlPrevious).Row - 10
        If rng_feuil1.Offset(i, 0) = "XXX" Then

            rng_project.Offset(0, 0) = rng_feuil1.Offset(i, 0)  'C10 de Feuil1 to A8 de project
            rng_project.Offset(0, 1) = rng_feuil1.Offset(i, 1) 'D10 de Feuil1 to B8 de project
            rng_project.Offset(0, 2) = rng_feuil1.Offset(i, 4) 'G10 de Feuil1 to C8 de project
            rng_project.Offset(0, 3) = rng_feuil1.Offset(i, 5) 'H10 de Feuil1 to D8 de project
            rng_project.Offset(0, 4) = rng_feuil1.Offset(i, 10) 'M10 de Feuil1 to E8 de project
            rng_project.Offset(0, 5) = rng_feuil1.Offset(i, 11) 'N10 de Feuil1 to F8 de project
            rng_project.Offset(0, 6) = rng_feuil1.Offset(i, 19) 'V10 de Feuil1 to G8 de project
            rng_project.Offset(0, 11) = rng_feuil1.Offset(i, 21) 'X10 de Feuil1 to L8 de project

            Set rng_project = rng_project.Offset(1, 0)
        End If
    Next i

End With

End Sub

Je vous joins mon fichier test. Mon probléme réside plutôt dans l'écriture ...

Merci de votre aide

À tester!

Bonjour,

Sub Test()

    Dim FeM0 As Worksheet
    Dim FeAP As Worksheet
    Dim Plage As Range
    Dim Cel As Range
    Dim J As Integer

    Set FeAP = Worksheets("Analyse Programme")
    Set FeM0 = Worksheets("M0 Seulement")

    With FeAP: Set Plage = .Range(.Cells(1, 4), .Cells(.Rows.Count, 4).End(xlUp)): End With

    FeM0.Range("A:L").ClearContents

    For Each Cel In Plage

        If Cel.Value = "Oui" Then

            J = J + 1
            FeM0.Range(FeM0.Cells(J, 1), FeM0.Cells(J, 13)).Value = FeAP.Range(FeAP.Cells(Cel.Row, 1), FeAP.Cells(Cel.Row, 13)).Value

        End If

    Next Cel

End Sub

Super Theze, c'est exactement ca. Mais est-il possible de garder la mise en forme ? ( couleur, ....)

Sinon, crackwood001 c'est ça aussi, mais je ne suis pas sur de comprendre tout le code à l'inverse de Theze ...

Alors, sous forme de copie :

Sub Test()

    Dim FeM0 As Worksheet
    Dim FeAP As Worksheet
    Dim Plage As Range
    Dim Cel As Range
    Dim J As Integer

    Set FeAP = Worksheets("Analyse Programme")
    Set FeM0 = Worksheets("M0 Seulement")

    With FeAP: Set Plage = .Range(.Cells(1, 4), .Cells(.Rows.Count, 4).End(xlUp)): End With

    FeM0.Range("A:L").ClearContents

    For Each Cel In Plage

        If Cel.Value = "Oui" Then

            J = J + 1
            FeAP.Range(FeAP.Cells(Cel.Row, 1), FeAP.Cells(Cel.Row, 13)).Copy FeM0.Range(FeM0.Cells(J, 1), FeM0.Cells(J, 13))

        End If

    Next Cel

End Sub

En merci Theze,

Voila mes questions:

 With FeAP: Set Plage = .Range(.Cells(1, 4)

Dans

.Cells(1, 4)

on part de la case (1;4)? Donc si je souhaite partir d'une autre ligne je change le 1 ?

FeM0.Range("A:L").ClearContents

Range("A:L")

c'est mon nombre de colonne ? Donc si je veux aller plus loin je change le L ? Peut-on automatiser cela et l'adapté à un cas quelconque ?

FeM0.Range(FeM0.Cells(J, 1), FeM0.Cells(J, 13)).Value = FeAP.Range(FeAP.Cells(Cel.Row, 1), FeAP.Cells(Cel.Row, 13)).Value

Dans

FeM0.Cells(J, 1)

J donne la colonne dans laquelle on travail et 1 donne la colonne. Donc si je veux copier plus bas je change le 1 en une autre valeur. L'indice J commence a 1 ?

J=J+1

FeM0.Cells(J, 13)

ça correspond à la cellule non vide étant la plus loin de ma page Analyse programme, par comparaison avec le code

FeAP.Cells(Cel.Row, 13)

?

Mettons à présent que la longueur de la ligne (13 ici) ne soit pas fixé et qu'au fur et à mesure ou je rentre des données, ce dernier change, comment je peux faire pour l'indexage ? Moi je souhaite qu'il aille jusqu'à ce que la case soit vide. Le 13 ici doit correspond à la valeur du L cité plus haut.

Merci pour ton aide Theze

Dans la ligne de code ci-dessous :

With FeAP: Set Plage = .Range(.Cells(1, 4), .Cells(.Rows.Count, 4).End(xlUp)): End With

effectivement, le chiffre 1 prend en compte la première ligne de la feuille, le 4 étant la 4ème colonne donc la colonne D

La ligne de code ci-dessous :

FeM0.Range("A:L").ClearContents

permet de vider les colonne de A à L, il te suffit de changer L en O par exemple pour vider les colonnes de A à O ou de changer A en D par exemple pour vider les colonnes de D à L. Je n'est pas pris le soin de rechercher la dernière ligne non vide de la feuille, ça va plus vite de cette façon mais attention, ça prend les colonnes entières c'est à dire que ça commence à la ligne 1 jusqu'à Rows.Count (dernière ligne de la feuille)

Dans la ligne de code ci-dessous :

FeM0.Range(FeM0.Cells(J, 1), FeM0.Cells(J, 13)).Value = FeAP.Range(FeAP.Cells(Cel.Row, 1), FeAP.Cells(Cel.Row, 13)).Value

J représente le numéro de ligne et est incrémenté de façon à coller les valeurs les unes à la suites des autres. Si par exemple tu souhaites que les valeurs commence à être collées à la ligne 15, tu peux faire ça :

J = 14 'on initialise pour commencer à une ligne autre que la première

For Each Cel In Plage

    If Cel.Value = "Oui" Then

        J = J + 1 'au 1er passage, J aura la valeur de 15 (14 de départ + 1 ajouté ici !)
        FeAP.Range(FeAP.Cells(Cel.Row, 1), FeAP.Cells(Cel.Row, 13)).Copy FeM0.Range(FeM0.Cells(J, 1), FeM0.Cells(J, 13))

    End If

Next Cel

ou ça :

J = 15 'on initialise à 15 pour commencer à la 15ème ligne...

For Each Cel In Plage

    If Cel.Value = "Oui" Then

        FeAP.Range(FeAP.Cells(Cel.Row, 1), FeAP.Cells(Cel.Row, 13)).Copy FeM0.Range(FeM0.Cells(J, 1), FeM0.Cells(J, 13))
        J = J + 1 '<-- puis on incrémente après avoir collé !

    End If

Next Cel

Dans la propriété Cells(RowIndex, ColumnIndex), le 1er argument attend le numéro de ligne et le second, le numéro de colonne.

Ceci :

FeM0.Cells(J, 13)

représente effectivement la cellule en ligne J et colonne 13 donc la colonne M

Si le nombre de cellules varie d'une ligne à l'autre, il te suffit de rechercher la dernière cellule non vide sur la ligne J. Dans le code ci-dessous, c'est la variable K qui reçoit cette valeur :

Sub Test()

    Dim FeM0 As Worksheet
    Dim FeAP As Worksheet
    Dim Plage As Range
    Dim Cel As Range
    Dim J As Integer
    Dim K As Integer

    Set FeAP = Worksheets("Analyse Programme")
    Set FeM0 = Worksheets("M0 Seulement")

    With FeAP: Set Plage = .Range(.Cells(1, 4), .Cells(.Rows.Count, 4).End(xlUp)): End With

    FeM0.Range("A:L").ClearContents

    J = 15 'on initialise pour commencer à la ligne 15

    For Each Cel In Plage

        If Cel.Value = "Oui" Then

            'recherche la dernière cellule non vide sur la ligne J en partant de l'extrémité droite de la feuille et en revenant vers la gauche (xlToLeft)
            With FeAP: K = .Cells(J, .Columns.Count).End(xlToLeft).Column: End With

            FeAP.Range(FeAP.Cells(Cel.Row, 1), FeAP.Cells(Cel.Row, K)).Copy FeM0.Range(FeM0.Cells(J, 1), FeM0.Cells(J, K))
            J = J + 1 'puis on incrémente pour passer à la ligne suivante

        End If

    Next Cel

End Sub

Excellent Theze. Parfait. Cela correspond tout à fait à mon besoin.

Quand je lance, ce me sort une erreur:

Set FeAP = Worksheets("Analyse Programmes")

Worksheets("Analyse Programmes")=<L'indice n'appartient pas à la selection>

J'ai copié collé ton script ... Une idée ?

Ta feuille s'appelle bien "Analyse Programmes" avec un "s" à "Programme(s)" ?

Dans mon code c'est sans "s" comme dans ton classeur exemple posté.

C'est juste que le nom de l'onglet n'est strictement pas identique donc, double clic sur l'onglet, copier et coller !

Bien vu, je pensais déjà avoir réglé le probléme, mais il y avait un espace après le s dans le nom de mon onglet ...

Merci infiniement pour ton aide Theze

J'ai une légère modification à effectuer dans mon programme et la voici:

• Aujourd'hui je nettoie ma feuille puis je viens coller mes datas lorsque je clique sur le bouton.
• Je modifie les cases au cas par cas, c'est à dire que je change la couleur des cases que j'ai copié dans ma nouvelle feuille.

Je souhaite modifier mon code pour faire en sorte de ne plus écraser les cellules que j'ai copié afin de garder la mise en forme et donc les modifications que j'ai faites. Pour cela, j'ai supprimer le "clear" et je souhaite rajouter une condition qui est la suivante:

- Si la Cellule contient un oui et que la cellule située 2 colonnes avant est présent dans ma nouvelle feuille alors j'effectue une copie.

J'ai donc rajouté à mon code

found = Worksheets("M0").Find(ActiveCell(, -2), LookAt:=xlWhole)
            If ActiveCell.Value = "Oui" Then
                If found Is Nothing Then

Mais cela ne fonctionne pas.

Je joins le code surlequel je travail en ce moment.

Sub CopCol()

    Dim FeM0 As Worksheet
    Dim FeAP As Worksheet
    Dim PlageAP As Range
    Dim PlageM0 As Range
    Dim Cellule As Range
    Dim j As Integer
    Dim K As Integer
    Dim found As Range

    j = 9
    'on initialise pour commencer à la ligne 9

    Set FeAP = Worksheets("Analyse Programmes")
    Set FeM0 = Worksheets("M0")

    With FeAP: Set PlageAP = .Range(.Cells(10, 1), .Cells(.Rows.Count, 4).End(xlUp)): End With
    With FeM0: Set PlageM0 = .Range(.Cells(10, 4), .Cells(.Rows.Count, 4).End(xlUp)): End With

        For Each Cellule In PlageAP(, 4).End(xlUp)
        found = Worksheets("M0").Find(ActiveCell(, -2), LookAt:=xlWhole)
            If ActiveCell.Value = "Oui" Then
                If found Is Nothing Then
                    'recherche la dernière cellule non vide sur la ligne J en partant de l'extrémité droite de la feuille et en revenant vers la gauche (xlToLeft)
                    With FeAP: K = .Cells(j, .Columns.Count).End(xlToRight).Column: End With
                    FeAP.Range(FeAP.Cells(Cellule.Row, 1), FeAP.Cells(Cellule.Row, K)).Copy FeM0.Range(FeM0.Cells(j, 1), FeM0.Cells(j, K))
                    j = j + 1 'puis on incrémente pour passer à la ligne suivante
                End If
            End If
            Next Cellule
'End If
'Next CellNCAP
End Sub

Avez-vous une proposition de solution à m'apporter ? Je pense qu'il s'agit de la forme du find qui ne convient pas. Je cherche à travailler sur la cellule active, c'est à dire la même cellule que la cellule du Each Cellule.

Merci de votre aide

Bonjour,

Je ne suis pas sûr de tout comprendre ce que tu souhaites mais voilà le code pondu à tester :

Sub CopCol()

    Dim FeM0 As Worksheet
    Dim FeAP As Worksheet
    Dim PlageAP As Range
    Dim PlageM0 As Range
    Dim CelAP As Range
    Dim CelMO As Range
    Dim j As Integer
    Dim K As Integer

    Set FeAP = Worksheets("Analyse Programme")
    Set FeM0 = Worksheets("M0 Seulement")

    With FeAP: Set PlageAP = .Range(.Cells(1, 4), .Cells(.Rows.Count, 4).End(xlUp)): End With
    With FeM0: Set PlageM0 = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)): End With

    j = 9 'on initialise pour commencer à la ligne 9

    For Each CelAP In PlageAP

        If CelAP.Value = "Oui" Then

            'recherche la valeur de la colonne B de la feuille "Analyse Programme" dans la colonne B de la feuille "M0 Seulement"
            Set CelMO = PlageM0.Find(CelAP.Offset(, -2).Value, , xlValues, xlWhole)

            'si elle existe, copie
            If Not CelMO Is Nothing Then

                'recherche la dernière cellule non vide sur la ligne J en partant de l'extrémité droite
                'attention à la valeur de J, il débute à 9 donc 9 ème ligne !!!
                With FeAP: K = .Cells(j, .Columns.Count).End(xlToLeft).Column: End With

                FeAP.Range(FeAP.Cells(CelAP.Row, 1), FeAP.Cells(CelAP.Row, K)).Copy FeM0.Range(FeM0.Cells(j, 1), FeM0.Cells(j, K))
                j = j + 1

            End If

        End If

    Next CelAP

End Sub

Je regarde ca. J'ai un petit soucis dans la sortie a régler.

En revanche, ca devrait étre.

( On fait la copie si le résultat du "Find" donne Rien (0/Nothing) ?

 If CelMO Is Nothing Then

Et non pas:

 If Not CelMO Is Nothing Then

J'ai un soucis, en ajoutant un ligne dans ma feuille Analyses Programmes, et en cliquant sur le bouton, ça ne donne rien de nouveau dans ma page ...

EDIT1: J'ai essayé de nettoyer ma feuille en supprimant ce qu'il y a dessus, mais en relancant le programme, je n'ai aucun résultats qui s'affiche ...

EDIT2: Est-il possible que suivant la nature de la values dans la colonne ou l'on fait l'offset, il ne veut pas me copier les données ? Car j'ai des données qui sont issus d'un recherchev et c'est celle qui me bloque ...

EDIT3: Je pense que l'on problème vient de la "mise à jour", j'ai l'impression en ayant effectué quelques tests, que superpose les nouvelles données que l'on fait apparaître dans "Analyse Programmes" vers M0. Je suis pas mal à cours d'idées sur comment faire ...

Sub CopCol()

    Dim FeM0 As Worksheet
    Dim FeAP As Worksheet
    Dim PlageAP As Range
    Dim PlageM0 As Range
    Dim CelAP As Range
    Dim CelMO As Range
    Dim j As Integer
    Dim K As Integer

    j = 9 'on initialise pour commencer à la ligne 9

    Set FeAP = Worksheets("Analyse Programmes")
    Set FeM0 = Worksheets("M0")

    With FeAP: Set PlageAP = .Range(.Cells(1, 4), .Cells(.Rows.Count, 4).End(xlUp)): End With
    With FeM0: Set PlageM0 = .Range(.Cells(j, 2), .Cells(.Rows.Count, 2).End(xlUp)): End With

    For Each CelAP In PlageAP

        If CelAP.Value = "Oui" Then

            'recherche la valeur de la colonne B de la feuille "Analyse Programme" dans la colonne B de la feuille "M0 Seulement"
            Set CelMO = PlageM0.Find(CelAP.Offset(, -2).Value, , xlValues, xlWhole)

            'si elle existe, copie
            If CelMO Is Nothing Then

                'recherche la dernière cellule non vide sur la ligne J en partant de l'extrémité droite
                'attention à la valeur de J, il débute à 9 donc 9 ème ligne !!!
                With FeAP: K = .Cells(j, .Columns.Count).End(xlToLeft).Column: End With

                FeAP.Range(FeAP.Cells(CelAP.Row, 1), FeAP.Cells(CelAP.Row, K)).Copy FeM0.Range(FeM0.Cells(j, 1), FeM0.Cells(j, K))
                j = j + 1

            End If

        End If

    Next CelAP

End Sub