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
- Messages
- 409
- Excel
- 365, Anglais
- Inscrit
- 07/03/2016
- Emploi
- Entrepreneur en construction
À 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