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 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 ...

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
278
  • Question Question
Microsoft 365 Probléme VBA
Réponses
8
Affichages
329
  • Question Question
Microsoft 365 worksheet_change
Réponses
29
Affichages
523
Réponses
2
Affichages
127
Réponses
4
Affichages
205
Réponses
5
Affichages
245
Retour