Gestion des couleurs ...

[fireball]

Bonjour,

j'ai un tableau dans lequel j'aimerai que les celules soient coloriés en fonction de leur contenu ... il y a trop de couleur pour effextuer une mise ne forme conditionnelle !! de plus, je souhaiterai que la macro puisse reconnaitre au moins une partie du texte de la cellule.

Voilà ce que j'ai mais ça ne sélectionne que les cellules contenant exclusivement le texte inscrit sur ma page "couleurs" alors que je voudrai ajouter plus de texte!!! :

Sub Colorier()
Application.ScreenUpdating = False
Dim Tblo
Sheets("couleur").Activate 'feuille de référence des couleurs
Range("A1").Select
With Selection.CurrentRegion
Intersect(.Cells, .Offset(1)).Select
End With
Tblo = Selection.Value
[A1].Select
Sheets("Planning").Activate 'feuille de saisie du texte
Range("B3").Select
With Selection.CurrentRegion
Intersect(.Cells, .Offset(1, 1)).Select
End With
For Each Cell In Selection
If Cell = "" Then Cell.Interior.ColorIndex = xlNone: GoTo Suite
For i = 1 To UBound(Tblo, 1)
If Tblo(i, 1) = Cell.Value Then Exit For
Next i
On Error Resume Next
Cell.Interior.ColorIndex = Tblo(i, 2)
On Error GoTo 0
Suite:
Next Cell
[A2].Select
End Sub

Ci joint mon fichier d'exemple ...

Merci du coup de main!

 

[Dranreb]

Re : Gestion des couleurs ...

Bonjour.
Il faut une règle de recherche
Par exemple: chercher dans la table le pluis grand groupe des premiers mots de la cellule qui n'a pas plus de 11 caractères de long. Ça irait ?
À+

 

[tototiti2008]

Re : Gestion des couleurs ...

Bonjour fireball, Bonjour Dranreb,

un essai (j'ai enlevé les Select de ton code mais le principe est le même, si ce n'est l'utilisation de Like)

Sub Colorier()
    Dim Tblo, Cellule As Range
    Application.ScreenUpdating = False
    With Sheets("couleur")
        Tblo = Application.Intersect(.Range("A1").CurrentRegion, .Range("A1").CurrentRegion.Offset(1)).Value
    End With
    With Sheets("planning")
        For Each Cellule In Intersect(.Range("B3").CurrentRegion, .Range("B3").CurrentRegion.Offset(1, 1))
            If Cellule.Value = "" Then
                Cellule.Interior.ColorIndex = xlNone
            Else
                For i = 1 To UBound(Tblo, 1)
                    If LCase(Cellule.Value) Like "*" & LCase(Tblo(i, 1)) & "*" Then Exit For
                Next i
                Cellule.Interior.ColorIndex = Tblo(i, 2)
            End If
        Next Cellule
    End With
End Sub

 

[Dranreb]

Re : Gestion des couleurs ...

Bon, eh bien je ne vais pas le réécrire avec un Find puisque je suis devancé autrement !
Remarque: on pourrait récupérer le Interior.Colorindex de la première colonne de la table
À+

 

[Fo_rum]

Re : Gestion des couleurs ...

Bonjour,

un autre essai

Sub Colorier()
    Dim cell As Range, Cels As Range
    Application.ScreenUpdating = False
    For Each Cels In Sheets("couleur").[A2:A10]
        For Each cell In Cells.CurrentRegion
            If cell Like Cels & " *" Or Cels Like cell & "*" Then cell.Interior.ColorIndex = Cels.Interior.ColorIndex
        Next
    Next
End Sub

 

[fireball]

Re : Gestion des couleurs ...

super merci à tous!