Trouver / copier ligne de couleur et coller dans autre feuille
dol91
Messages postés
3
Statut
Membre
-
dol91 Messages postés 3 Statut Membre -
dol91 Messages postés 3 Statut Membre -
Bonjour,
Je rencontre un probleme insoluble pour moi , neo pratiquant de VBA .
je desire , apres avoir coller un tableau dans une feuille , rechercher les lignes colorées en jaune et les coller dans une autre feuille appelée "synthese" les unes sous les autres ..
Voici mon code :
Dim Cellule1 As Range, Cellule2 As Range
Dim lig As Integer, col As Integer
Dim flag As Boolean
lig = 3: col = 1
With Sheets("Feuil1")
For Each Cellule1 In Intersect(.Range("A:A"), .UsedRange)
For Each Cellule2 In Intersect(.Rows(Cellule1.Row), .UsedRange)
If Cellule2.Interior.Color = RGB(255, 255, 0) Then
Sheets("Synthese").Cells(lig, col) = Cellule2
col = col + 1
flag = True
End If
Next Cellule2
If flag = True Then lig = lig + 1: flag = False
Next Cellule1
End With
Il marche assez bien pour rechercher et coller la 1ere ligne jaune trouvée mais ne fonctionne plus des qu'il en trouve une autre . Ou il la colle a la suite sur la meme ligne , ou n'importe ou ... Et surtout , des que je refais la manoeuvre avec un nouveau tableau le lendemain , la nouvelle ligne jaune trouvée ecrase la precedente .
Je m'arrache les cheveux ! ( et Dieu sait qu'il m'en reste deja peu ...)
Quelqu'un peut-il m'aider ?
Merci par avance
Je rencontre un probleme insoluble pour moi , neo pratiquant de VBA .
je desire , apres avoir coller un tableau dans une feuille , rechercher les lignes colorées en jaune et les coller dans une autre feuille appelée "synthese" les unes sous les autres ..
Voici mon code :
Dim Cellule1 As Range, Cellule2 As Range
Dim lig As Integer, col As Integer
Dim flag As Boolean
lig = 3: col = 1
With Sheets("Feuil1")
For Each Cellule1 In Intersect(.Range("A:A"), .UsedRange)
For Each Cellule2 In Intersect(.Rows(Cellule1.Row), .UsedRange)
If Cellule2.Interior.Color = RGB(255, 255, 0) Then
Sheets("Synthese").Cells(lig, col) = Cellule2
col = col + 1
flag = True
End If
Next Cellule2
If flag = True Then lig = lig + 1: flag = False
Next Cellule1
End With
Il marche assez bien pour rechercher et coller la 1ere ligne jaune trouvée mais ne fonctionne plus des qu'il en trouve une autre . Ou il la colle a la suite sur la meme ligne , ou n'importe ou ... Et surtout , des que je refais la manoeuvre avec un nouveau tableau le lendemain , la nouvelle ligne jaune trouvée ecrase la precedente .
Je m'arrache les cheveux ! ( et Dieu sait qu'il m'en reste deja peu ...)
Quelqu'un peut-il m'aider ?
Merci par avance
3 réponses
-
Bonjour,
Le flag doit faire des siennes. Ton code me semble un peu compliqué.
Peut-être peux-tu t'inspirer de ça :derLigne = Sheets("Données").Range("A" & Rows.Count).End(xlUp).Row ligneDest = Sheets("Synthèse").Range("A" & Rows.Count).End(xlUp).Row + 1 For i = 2 To derLigne If Sheets("Données").Cells(i, 1).Interior.Color = RGB(255, 255, 0) Then Sheets("Données").Cells(i, 1).EntireRow.Copy Sheets("Synthèse").Activate Cells(ligneDest, 1).Select ActiveSheet.Paste ligneDest = ligneDest + 1 End If Next i
A+ -
Bonjour,
A priori, ton code n'est pas conçu pour rechercher les lignes colorées en jaune et les coller dans une autre feuille appelée "synthese" les unes sous les autres ..
Il cherche dans la plage utilisée les cellules colorées en jaunes et il les colle en lignes et colonnes suivant l'ordre de recherche.
Pour permettre aux intervenants de t'aider efficacement, il est souhaitable que tu joignes un fichier à ta demande avec un exemple de résultat souhaité.
Pour joindre le fichier, tu peux utiliser https://www.cjoint.com/
Ensuite, reviens coller ici le lien donné par le site.
A+ -
Bonjour !
Pour commencer , je voulais vous remercier pour vos reponses rapides !
Apres adaptation de ton code , Zoul67 , il fonctionne tres bien et remplit la fonction voulue .
Merci encore et bonne jourée à tous !
