Copier Coller une ligne si une cellule est surligner en rouge [Résolu]

Signaler
Messages postés
9
Date d'inscription
jeudi 22 avril 2021
Statut
Membre
Dernière intervention
2 juin 2021
-
Messages postés
10056
Date d'inscription
mercredi 11 août 2004
Statut
Contributeur
Dernière intervention
12 juin 2021
-
Bonjour,

Je voudrais copier coller une ligne si celle ci est surligné en rouge, dans une autre feuille nommée "Alerte".
Il peut y avoir plusieurs ligne surligner en rouge, je voudrais donc les mettre à la suite.

Merci d'avance

Voici mon code,

Const coul1 = 15
Const coul2 = xlNone
Const codeb = 1
Const coreg = 3
Const coite = 4
Const copre = 6
Const cocam = 7
Const corec = 8
Const coext = 9
Const copro = 10
Const comac = 11
Const lideb = 2
Const rouge = 3
Const vert = 50

Public Sub ok()
Dim li As Long, lifin As Long, coul As Long
Dim reg As String, li1 As Long, li2 As Long, ok As Boolean
Dim cofin As Long, co As Long, s As Long, plage As Range, cel As Range, lc As String
Dim mac As Long, ite As String
Dim obj As Object, liobj As Long
lifin = Cells(Rows.Count, coreg).End(xlUp).Row
cofin = Cells(1, Columns.Count).End(xlToLeft).Column
Set plage = Range(Cells(lideb, codeb), Cells(lifin, cofin))
plage.Interior.ColorIndex = xlNone
plage.Interior.ColorIndex = xlAutomatic
Application.ScreenUpdating = False
coul = coul1
Range(Cells(lideb, codeb), Cells(lideb, cofin)).Interior.ColorIndex = coul
' alternance coul1 - coul2
For li = lideb + 1 To lifin
  Range(Cells(li, codeb), Cells(li, cofin)).Interior.ColorIndex = coul
  If Cells(li, coreg).Value <> Cells(li + 1, coreg) Then coul = coul1 + coul2 - coul
Next li
' les surlignements rouges
li1 = lideb
Do
  reg = Cells(li1, coreg).Value
  ok = True
  lc = ""
  li2 = li1
  While Cells(li2, coreg).Value = reg And li2 <= lifin
    Set plage = Range(Cells(li2, copre), Cells(li2, copro))
    s = Application.WorksheetFunction.Sum(plage)
    If s <> 1 Then ok = False
    If ok Then
      For Each cel In plage
        If cel.Value <> "" Then
          co = cel.Column
          If co = corec Or co = coext Then co = corec
          If InStr(1, lc, co - 1) = 0 Then lc = lc & co - 1
        End If
      Next cel
      If Len(lc) > 1 Then ok = False
    End If
    li2 = li2 + 1
  Wend
suite:
  If Not ok Then Range(Cells(li1, codeb + 1), Cells(li2 - 1, cofin)).Interior.ColorIndex = rouge
  If Not ok Then Range(Cells(li1, codeb + 1), Cells(li2 - 1, cofin)).Select
  Selection.Copy
  Sheets("Feuil3").Select
  Range("A1").Select
  ActiveSheet.Paste
  li1 = li2
Loop Until li2 > lifin
' les surlignements verts
li1 = lideb
Do
  reg = Cells(li1, coreg).Value
  If Cells(li1, copro) = 1 Then
    ite = Cells(li1, coite).Value
    mac = Cells(li1, comac).Value
    Set plage = Range(Cells(li1, coite), Cells(lifin, coite))
    Set obj = plage.Find(ite, , , xlWhole)
    If Not obj Is Nothing Then
      liobj = obj.Row
      If Cells(liobj, copre).Value = 1 And Cells(liobj, comac).Value = mac + 1 Then
        Set plage = Range(Cells(li1, codeb), Cells(li1, cofin))
        plage.Font.ColorIndex = vert
        Set plage = Range(Cells(liobj, codeb), Cells(liobj, cofin))
        plage.Font.ColorIndex = vert
      End If
    End If
  End If
  li1 = li1 + 1
Loop Until li1 >= lifin
End Sub



Configuration: Windows / Chrome 91.0.4472.77

13 réponses

Messages postés
10056
Date d'inscription
mercredi 11 août 2004
Statut
Contributeur
Dernière intervention
12 juin 2021
1 149
Bonjour,
le code n'a rien à voir avec votre demande...!
Eh bien ou est votre problème?

Salutations.
Le Pingou

Bonjour,
Je n’arrive pas à choisir les cellules surligner en rouge afin de les coller dans la feuille « Alerte ».
Messages postés
10056
Date d'inscription
mercredi 11 août 2004
Statut
Contributeur
Dernière intervention
12 juin 2021
1 149
Bonjour,
Je peux savoir à quoi sert le code que vous avez posté!
Messages postés
9
Date d'inscription
jeudi 22 avril 2021
Statut
Membre
Dernière intervention
2 juin 2021

Bonjour,

J'ai des regroupements contenant des items, ces items doivent tous être au même endroit.
Si elles ne le sont pas, tout le regroupement est surligné en rouge (d'où la verif des colonnes).

Je veux maintenant créer une feuille "Alerte" avec tout les regroupements en rouge.
Je veux donc savoir comment je copie colle ces regroupements en rouge dans le feuille "Alerte".

C'est pour cela que j'ai ajouté le code

Merci d'avance
Messages postés
10056
Date d'inscription
mercredi 11 août 2004
Statut
Contributeur
Dernière intervention
12 juin 2021
1 149
Bonjour,
Merci.
voici le code pour copier et coller (si surligner en rouge la cellule de la colonne "A") la ligne vers la feuille "Alerte".
Sub CopColLigneS()
For li = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
    If 3 = Cells(li, 1).Interior.ColorIndex Then
        Rows(li).Copy
        Sheets("Alerte").Select
        Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Sheets("Feuil1").Activate
    End If
Next li
Application.ScreenUpdating = True
End Sub

Messages postés
9
Date d'inscription
jeudi 22 avril 2021
Statut
Membre
Dernière intervention
2 juin 2021

Merci,

Malheureusement, j'obtiens ce message:
"Erreur d'exécution '1004':
Vous ne pouvez pas coller cet élément ici, car les zones copier et de collage sont de tailles différente.
Selectionnez une seule cellule dans la zone de collage ou une zone de même taille, puis réessayez de coller"

De plus, si je comprend bien le code:
If 3 = Cells(li, 1).Interior.ColorIndex Then

Correspond à "si le surlignement de la cellule(li, Colonne A) est rouge"
Si je veux choisir la colonne c par exemple je modifie à :
If 3 = Cells(li, 3).Interior.ColorIndex Then
?

Merci d'avance
Messages postés
10056
Date d'inscription
mercredi 11 août 2004
Statut
Contributeur
Dernière intervention
12 juin 2021
1 149
Bonjour,
Chez moi le code est parfait il fait exactement selon : Copier-Coller une ligne si une cellule est surlignée en rouge : Il prend en compte la couleur de surlignage de la cellule de la colonne "A:A".
Je ne sais pas la structure de votre base de données…je ne peux rien dire de plus... !
Pour l'indice de colonne "C" =3 pour "A"=1 c'est correct

Salutations.
Le Pingou
Messages postés
9
Date d'inscription
jeudi 22 avril 2021
Statut
Membre
Dernière intervention
2 juin 2021

Bonjour,

J'ai réglé le dernier problème, malheureusement j'en ai un autre (je n'ai pas beaucoup de chance)
Le code copie colle bien les lignes en rouge, néanmoins dans la feuille alerte j'ai seulement la dernière ligne surligner en rouge.

Comment je fais pour que cela se copie colle à la première ligne vide (La colonne où j'ai toujours quelque chose de non vide est la colonne C).

Merci beaucoup
Messages postés
10056
Date d'inscription
mercredi 11 août 2004
Statut
Contributeur
Dernière intervention
12 juin 2021
1 149
Bonjour,
Il fonctionne correctement chez moi.
Mettez moi à disposition le code complet tel que vous l'utilisé .
Une image des 2 feuilles (feuille de donnée et Alerte)

Salutations.
Le Pingou
Messages postés
9
Date d'inscription
jeudi 22 avril 2021
Statut
Membre
Dernière intervention
2 juin 2021



Voici la feuille de données. Il faut savoir que la feuille de donnees comprend plus de 300 lignes, je ne vous joins donc pas la totalité et voici le fichier alerte:


Sur ce dernier nous avons seulement la derniere ligne rouge de la feuille de donnees
Messages postés
10056
Date d'inscription
mercredi 11 août 2004
Statut
Contributeur
Dernière intervention
12 juin 2021
1 149
Bonjour,
Merci, cependant la première image sans les en-têtes ne me serve à rien et en plus il manque le code !
Dans un premier temps essayez de modifier ma ligne de code comme suit:
Range("C" & Rows.Count).End(xlUp).Offset(1, -2).Select

Note je serais absent jusqu'en début d'après-midi.

Salutations.
Le Pingou
Messages postés
9
Date d'inscription
jeudi 22 avril 2021
Statut
Membre
Dernière intervention
2 juin 2021

Bonjour,

En modifiant votre ligne de code, j'ai bien ce qu'il faut merci beaucoup.

C'est un peu compliqué de vous joindre la totalité du code. En effet, la feuille de données provient d'un tableau croisé dynamique qui trouve sa source dans un fichier externe qui s'actualise toutes les 15 minutes.

Merci pour votre aide,
Cordialement,
Messages postés
10056
Date d'inscription
mercredi 11 août 2004
Statut
Contributeur
Dernière intervention
12 juin 2021
1 149
Bonjour,
Le principale est que cette fois c'est OK.
Merci de marquer Résolu si c'est le cas.