Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Gestion des couleurs ...

  • Initiateur de la discussion Initiateur de la discussion fireball
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

fireball

XLDnaute Nouveau
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!
 

Pièces jointes

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 ?
À+
 
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)

Code:
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
 
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
À+
 
Re : Gestion des couleurs ...

Bonjour,

un autre essai
Code:
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
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
5
Affichages
300
  • Question Question
Microsoft 365 Probléme VBA
Réponses
8
Affichages
332
  • Question Question
Microsoft 365 worksheet_change
Réponses
29
Affichages
544
Réponses
2
Affichages
127
Réponses
4
Affichages
217
Réponses
5
Affichages
249
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…