Microsoft 365 Colorer une plage en fonction d'un contenu de cellule

[de_hanstrapp]

Bonsoir le forum,

Dans le fichier joint, je souhaiterais écrire un code vba qui me permette en fonction du contenu de la colonne "C" colore une plage de la même ligne.
Il peut y avoir jusqu'à une centaine de contenus différents dan la colonne "C"... et le nombre de ligne est compris entre 1500 et 2000.

Couleur de la plage : R 217 - V 225 - B 242

J'ai essayé via les Mises en forme conditionnelles mais le travail est long est source d'erreurs...

Quelqu'un aurait une idée ?

Bonne soirée,

De_hanstrapp

 

[job75]

Bonsoir de_hanstrapp,

Comment sont définies les plages à colorer ?

A+

 

[job75]

Bon je suppose que les plages sont définies par la 1ère ligne de chaque texte.

Alors voyez le fichier joint et cette macro :

Sub MAJ()
Dim t, d As Object, i&, x$
t = Timer
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For i = 10 To Range("C" & Rows.Count).End(xlUp).Row
    x = Cells(i, 3)
    If d.exists(x) Then Rows(d(x)).Copy Rows(i) Else d(x) = i
Next
MsgBox "Mise à jour en " & Format(Timer - t, "0.00 \sec")
End Sub

Sur 1300 lignes chez moi elle s'exécute en 5 secondes.

Bonne nuit.

 

[de_hanstrapp]

Bonsoir de_hanstrapp,

Comment sont définies les plages à colorer ?

A+

Bonjour job75,
Les plages sont définis par des calendriers fixes.
Par exemple Texte (A) - > du 24/07/2023 au 01/08/2023.
Et toutes les cellules ou figurent Texte (A) doivent colorer la même période.
De_hanstrapp

 

[de_hanstrapp]

Bon je suppose que les plages sont définies par la 1ère ligne de chaque texte.

Alors voyez le fichier joint et cette macro :

Sub MAJ()
Dim t, d As Object, i&, x$
t = Timer
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For i = 10 To Range("C" & Rows.Count).End(xlUp).Row
    x = Cells(i, 3)
    If d.exists(x) Then Rows(d(x)).Copy Rows(i) Else d(x) = i
Next
MsgBox "Mise à jour en " & Format(Timer - t, "0.00 \sec")
End Sub

Sur 1300 lignes chez moi elle s'exécute en 5 secondes.

Bonne nuit.

Merci pour votre travail.
En fait, je voyais cela plutôt comme un formule du type : si C11 = "Texte (A)" colorer AD11:AL11 ou si C11 = "Texte (B)" colorer S11:W11 etc.
Sachant que je vais avoir 70-80 "Texte (qqchose)" différents.

 

[job75]

Bonjour,

Des formules ? Vous allez galérer s'il y en a une centaine de différentes...

A+

 

[job75]

Une autre solution consiste à mettre l'adresse de la plage à colorer dans la colonne auxiliaire B.

Bien sûr chaque adresse est à entrer une seule fois.

Cette macro est alors beaucoup plus rapide (0,06 seconde sur 1300 lignes) :

Sub MAJ()
Dim t, d As Object, tablo, i&, x$
t = Timer
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
tablo = Range("B1", Range("C" & Rows.Count).End(xlUp))
'---liste des références en colonne B---
For i = 11 To UBound(tablo)
    x = tablo(i, 1)
    If x <> "" Then d(tablo(i, 2)) = x
Next
'---coloration du tableau---
Rows("11:" & Rows.Count).Interior.ColorIndex = xlNone 'RAZ
For i = 11 To UBound(tablo)
    x = d(tablo(i, 2))
    If x <> "" Then Intersect(Range(x), Rows(i)).Interior.Color = RGB(217, 225, 242)
Next
MsgBox "Mise à jour en " & Format(Timer - t, "0.00 \sec")
End Sub

A+

 

[job75]

Notez qu'on peut entrer des plages multiples, par exemple S:V,X:Z en B13.

 

[de_hanstrapp]

Une autre solution consiste à mettre l'adresse de la plage à colorer dans la colonne auxiliaire B.

Bien sûr chaque adresse est à entrer une seule fois.

Cette macro est alors beaucoup plus rapide (0,06 seconde sur 1300 lignes) :

Sub MAJ()
Dim t, d As Object, tablo, i&, x$
t = Timer
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
tablo = Range("B1", Range("C" & Rows.Count).End(xlUp))
'---liste des références en colonne B---
For i = 11 To UBound(tablo)
    x = tablo(i, 1)
    If x <> "" Then d(tablo(i, 2)) = x
Next
'---coloration du tableau---
Rows("11:" & Rows.Count).Interior.ColorIndex = xlNone 'RAZ
For i = 11 To UBound(tablo)
    x = d(tablo(i, 2))
    If x <> "" Then Intersect(Range(x), Rows(i)).Interior.Color = RGB(217, 225, 242)
Next
MsgBox "Mise à jour en " & Format(Timer - t, "0.00 \sec")
End Sub

A+

C'est top !
Merci job75 pour l'aide.