Lister Cellules Colorées

Bonjour à tous,

J'aurais besoin d'aide svp.
J'ai des cellules colorées dans une feuille et j'aimerais lister l'adresse de toutes les cellules de couleur rouge présentes dans la feuille, si quelqu'un pourrait m'aider SVP.

Merci d'avance.

Bonjour à tous,

Elles ne sont pas rouge par hasard ? Si ?

Crdlmt

Bonjour,

Il se peut qu'il y ait d'autre couleur, mais j'aimerais que la recherche soit seulement le rouge (220, 20, 60)

Cordialement

bonjour,

Sub Chercher_Rouge()
     Dim FA, c, c0

     Set c0 = Range("A1:AZ50")     'la plage de recherche
     Application.FindFormat.Clear
     Application.FindFormat.Interior.Color = RGB(220, 20, 60)       'le couleur à chercher

     Set c = c0.Find("", SearchFormat:=True)
     If c Is Nothing Then Exit Sub
     FA = c.Address
     Set UN = c
     Do
          Set c = c0.Find("", after:=c, SearchFormat:=True)
          Set UN = Union(UN, c)
     Loop While FA <> c.Address
     Application.FindFormat.Clear

     MsgBox UN.Address

End Sub

Bonsoir,

Autre proposition :

Sub adress_cells_colorees()
Dim Cel As Range, Plg As Range
Set Plg = Range("A1:AS50") 'à définir
Dim Tmp
For Each Cel In Plg
    If coul_rgb(Cel.Interior.Color) Then
        Tmp = Tmp & Chr(10) & Cel.Address
    End If
Next Cel
Tmp = Split(Right(Tmp, Len(Tmp) - 1), Chr(10))
Range("AV1").Resize(UBound(Tmp) + 1) = Application.Transpose(Tmp)
End Sub

Function coul_rgb(Coul As Long) As Boolean
If Int(Coul Mod 256) = 220 And Int((Coul Mod 65536) / 256) = 20 And Int(Coul / 65536) = 60 Then
    coul_rgb = True
End If
End Function

Bonne soirée

Je vous remercie pour vos réponses rapide :) ,

Possible de mettre la liste dans une autre feuille svp afin que la liste soit exploitable ? au lieu de msgbox.

Merci beaucoup de votre aide

Re-,

Ceci s'adresse à?

@ cousinhub, c'est pour BsAlv,
Mais votre fonction marche bien, mais seulement lorsqu'on supprime quelque couleur et on remet la commande. Il y a une grande liste. Si possible de ne mettre uniquement que la liste des cases colorées SVP.

Merci beaucoup

Crdlmt

Re-,

Au cazou....

Sub adress_cells_colorees()
Dim Cel As Range, Plg As Range
Set Plg = Range("A1:AS50") 'à définir
Dim Tmp
For Each Cel In Plg
    If coul_rgb(Cel.Interior.Color) Then
        Tmp = Tmp & Chr(10) & Cel.Address
    End If
Next Cel
Tmp = Split(Right(Tmp, Len(Tmp) - 1), Chr(10))
With Sheets("Feuil2") 'A définir tout pareil
    .Columns(1).Clear
    .Range("A1").Resize(UBound(Tmp) + 1) = Application.Transpose(Tmp)
End with
End Sub

Function coul_rgb(Coul As Long) As Boolean
If Int(Coul Mod 256) = 220 And Int((Coul Mod 65536) / 256) = 20 And Int(Coul / 65536) = 60 Then
    coul_rgb = True
End If
End Function

Tout est résolu et je vous remercie beaucoup.

Bonne soirée :)

re,

ceci au lieu du msgbox

     sp = Split(UN.Address, ",")
     Range("a1").Resize(UBound(sp) + 1).Value = Application.Transpose(sp)

@Cousinhub, ceci est plus facile

Tmp = Split(mid(Tmp, 2), Chr(10))

Bonjour Tout l'monde.

BsAlv, merci pour ce code, je n'avais jamais utilisé "mid" sans le 3ème argument(facultatif)

Bien utile, je vais essayer de m'en souvenir

Merci encore, et bonne journée

BsAlv a écrit :

@Cousinhub, ceci est plus facile

Tmp = Split(mid(Tmp, 2), Chr(10))