XL 2010 Mise en forme conditionnel [VBA] critères multiple

Nylream · 19 Septembre 2017

Bonjour,

J'aimerais utiliser le VBA pour ma mise en forme conditionnel (je ne souhaite pas utiliser l'outil de base).
J'ai trois type de mise en forme pour mon tableau :

Un mot à mettre en rouge si présent
Doublon sur une même colonne : fond de la ligne à changer (prioritaire)
le fond d'une ligne à changer, en fonction de deux cellule (F et G) sur cette même ligne

Concrètement:

Si deux fois le même nom en colone A, le fond de la ligne en rouge
Si (F= "Navy") + (G = "O-11", "O-10", "O-9") alors couleurs #xxxx
Si (F= "Marines") + (G = "O-11", "O-10", "O-9") alors couleurs #yyyy
le mot "Unkow" toujours en rouge

J'ai testé pour le mot "Unknow" en rouge, mais en vain, les autres étant plus complexe, je cale.

Code:

Sub ColorOnDouble()

    Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$B2:$K="Unknow""
    ligne .Color = 255
   
End Sub

Merci d'avance pour votre aide,

Nylream · 19 Septembre 2017

Bonsoir,

J'ai un soucis avec les MFC :
Lorsque crée dans le menu de mise en forme conditionnelle, au départ tout vas bien, mais après quelques temps d'utilisation, les champs "s'applique à" et les "formules" se changent d'eux mêmes, et ne correspondent plus à ce que j'ai demandé. Parfois, de nouvelles règles se créent, et je sais ne pas les avoirs crée manuellement.
D'où ma recherche de VBA pour pouvoir gérer plus surement les mises en formes.

Problème, j'ai l'impression qu'en VBA, ça creé une MFC, au lieu de juste appliquer le code de couleur :

Le code suivant à fonctionné pour mettre en exergue les doublons en colonne A, mais lorsque j'ai testé quelques doublons, j'ai clairement vue pour chaqu'un une règle différente s'ajouter dans le menu MFC.
Forcement, ce n'est pas non plus ce que je veux, et si je pars dans cette directions, il y aura plus de règle dans cette feuille que de ligne dans mon tableau.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Set ObjRange = Range("A1").EntireColumn
With ObjRange.FormatConditions
    .Add Type:=xlExpression, Formula1:="=NB.SI(C1;LC)>1"
    .Item(.Count).Interior.Color = vbRed
End With
End Sub

J'aurais vraiment besoin d'un peu d'aide pour comprendre le fonctionnement de la mise en forme...

Merci d'avance pour toute aide,

Nylream.

job75 · 20 Septembre 2017

Bonjour Nylream,

Puisque les MFC donnent des soucis pourquoi en créer ? Il est aussi simple d'appliquer de vraies couleurs.

Avec une Worksheet_Change :

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim w$, x$, y$, z$, r As Range, d As Object
w = "Unknow": x = "Navy": y = "Marines": z = ",O-11,O-10,O-9,"
Application.ScreenUpdating = False
'---doublons en colonne A---
Set r = Intersect(Target, [A:A], UsedRange)
If Not r Is Nothing Then
  Set r = Intersect(Range("A2:A" & Rows.Count), UsedRange)
  r.Interior.ColorIndex = xlNone 'RAZ
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = vbTextCompare 'la casse est ignorée
  For Each r In r
    If d.exists(r.Value) Then
      Union(Cells(d(r.Value), 1), r).Interior.Color = vbRed
    Else
      If r <> "" Then d(r.Value) = r.Row 'mémorise la ligne
    End If
  Next
End If
'---polices en colonnes B:K---
Set r = Intersect(Target, [B:K], UsedRange)
If Not r Is Nothing Then
  r.Font.ColorIndex = xlAutomatic 'RAZ
  For Each r In r
    If r = w Then r.Font.Color = vbRed
  Next
End If
'---colonnes F et G---
Set r = Intersect(Target, [F:G], UsedRange)
If Not r Is Nothing Then
  Set r = Intersect(r.EntireRow, [F:G]).Rows
  r.Interior.ColorIndex = xlNone 'RAZ
  For Each r In Intersect(r.EntireRow, [F:G]).Rows
    If InStr(z, "," & r.Cells(2) & ",") Then
      If r.Cells(1) = x Then
        r.Cells(1).Resize(, 2).Interior.Color = vbCyan
      ElseIf r.Cells(1) = y Then
        r.Cells(1).Resize(, 2).Interior.Color = vbMagenta
      End If
    End If
  Next
End If
End Sub

C'est l'entrée de données en colonne A qui prend du temps car il faut traiter toute la colonne.

Si le tableau dépasse disons 5000 lignes il vaut mieux lancer cette macro [Edit] avec un raccourci clavier, Ctrl+m par exemple :

Code:

Sub Couleurs()
Dim w$, x$, y$, z$, d As Object, c As Range, col
w = "Unknow": x = "Navy": y = "Marines": z = ",O-11,O-10,O-9,"
Application.ScreenUpdating = False
Rows("2:" & Rows.Count).Interior.ColorIndex = xlNone 'RAZ
Rows("2:" & Rows.Count).Font.ColorIndex = xlAutomatic 'RAZ
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each c In ActiveSheet.UsedRange.Columns(1).Cells
  '---doublons en colonne A---
  If c <> "" Then
    If d.exists(c.Value) Then
      Union(Cells(d(c.Value), 1), c).Interior.Color = vbRed
    Else
      d(c.Value) = c.Row 'mémorise la ligne
    End If
  End If
  '---polices en colonnes B:K---
  For col = 1 To 11
    If c(1, col) = w Then c(1, col).Font.Color = vbRed
  Next
  '---colonnes F et G---
  If InStr(z, "," & c(1, 7) & ",") Then
    If c(1, 6) = x Then
      c(1, 6).Resize(, 2).Interior.Color = vbCyan
    ElseIf c(1, 6) = y Then
      c(1, 6).Resize(, 2).Interior.Color = vbMagenta
    End If
  End If
Next
End Sub

Testée sur sur 10 000 lignes : la durée d'exécution est de 2,9 secondes chez moi.

A+

Bebere · 20 Septembre 2017

enregistre une macro et tu auras la bonne syntaxe
sans vba
avec mise en forme conditionnelle
il faut sélectionner un type de règle,choisir la ligne utiliser une formule...
entrer cette formule et choisir une couleur

Code:

=ET(OU(F2="Navy";F2="Marines");OU(G2="0-9";G2="0-10";G2="0-11"))

job75 · 20 Septembre 2017

Bonsoir Bebere,

Oui mais :

Nylream à dit:
J'ai un soucis avec les MFC :
.....
D'où ma recherche de VBA pour pouvoir gérer plus surement les mises en formes.

Classique.

A+

Nylream · 21 Septembre 2017

Bonjour Job75, Bonjour Bebere,

Tout d'abord, merci pour vos réponses, Job75, je suis en train de tester le premier code, mon tableau ne devrait pas dépasser quelques centaine de ligne (600 environs).

En effet, lorsque je crée une MFC avec une formule, celle ci fonctionne très bien... pour un temps.
Premier problème, si je change la zone d'application pour la formule, ça modifie ma formule, pas grave, je la rechange.
Second problème, et là bien plus gênant et que je ne m'explique pas, après un certain temps d'utilisation, et sans que j'en comprenne le déclencheur, les MFC que j'ai crée manuellement changent, et d'autres "apparaissent" très similaire à celle d'origine, mais avec des différences malgré tout.
Exemple :
MFC pour mettre en rouge le mot "unknow"
celle d'origine pour le champs : =$A$2:$C$83 (en passant, moi j'avais rentrer "=Full" qui correspond à une zone variable)
Cette MFC à triplé à l'identique, puis une quatrième est apparu avec comme champ d'application :
=$D$2:$E$83;$H$2:$H$83;$A$61:$K$255

J'ai pour le moment, 13 règles MFC différentes, et toute font ont le même soucis, et je me suis donc retrouvé avec une cinquantaine de règles, plus ou moins identique et gérant plus ou moins la même chose avec des variantes.
La première fois, je les ai refaites, la seconde fois puis la troisième aussi.
La du coup, je cherche un moyen de ne plus avoir ce problème.

Désolé pour l'explication un peu longue et j'espère avoir été compréhensible, c'est dur avant le café.

Merci pour votre aide,

Nylream · 21 Septembre 2017

Re bonjour Job75,

La macro fonctionne, mais j'aimerais y apporter quelques modifications.
- Pour les doublons, seul un des deux est mis en exergue, est ce possible d'avoir les deux ?
- Pour les colorations, seuls les cellules des colonnes F et G sont coloré, j'ai essayé de remplacer par [A:K] mais du coup ça ne fonctionnait plus...

J'ai vue que que tu as préciser w = "Unknow": x = "Navy": y = "Marines": z = ",O-11,O-10,O-9,O-8,O-7,"
Je t'avoue que je ne m'attendais pas à un code si complexe, et j'ai du mal à le comprendre pour le modifier et y ajouter d'autres parties.
Il va falloir que j'y ajoute d'autres tranches de rangs, par exemple z1 = ",O-6,O-5," et z2 = ",O-4,O-3,O-2,O-1,O-C,".
Rajouter cette partie là ne me semble pas trop complexe, mais suis beaucoup moins sur pour les conditions plus bas ElseIf r.cells(1) = y Then

Penses tu pouvoir m'aider à comprendre / modifier ?
Surtout comprendre en fait, car je ne suis pas à l'abris de devoir en rajouter encore d'autre plus tard.

Merci beaucoup pour ton aide,

job75 · 21 Septembre 2017

Bonjour Nylream, le forum,

Pour les doublons en colonne A vous avez mal testé : les 2 sont colorés en rouge.

Pour les cellules en F:G ne pas colorer les colonnes A:K mais B:K puisque A peut être colorée en rouge :

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim w$, x$, y$, z$, r As Range, d As Object
w = "Unknow": x = "Navy": y = "Marines": z = ",O-11,O-10,O-9,"
Application.ScreenUpdating = False
'---doublons en colonne A---
Set r = Intersect(Target, [A:A], UsedRange)
If Not r Is Nothing Then
  Set r = Intersect(Range("A2:A" & Rows.Count), UsedRange)
  r.Interior.ColorIndex = xlNone 'RAZ
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = vbTextCompare 'la casse est ignorée
  For Each r In r
    If d.exists(r.Value) Then
      Union(Cells(d(r.Value), 1), r).Interior.Color = vbRed
    Else
      If r <> "" Then d(r.Value) = r.Row 'mémorise la ligne
    End If
  Next
End If
'---polices en colonnes B:K---
Set r = Intersect(Target, [B:C,F:G,I:K], UsedRange)
If Not r Is Nothing Then
  r.Font.ColorIndex = xlAutomatic 'RAZ
  For Each r In r
    If r = w Then r.Font.Color = vbRed
  Next
End If
Set r = Intersect(Target, UsedRange)
If Not r Is Nothing Then
  Intersect(r.EntireRow, [D:E,H:H]).Font.ColorIndex = xlNone 'RAZ
  For Each r In Intersect(r.EntireRow, [A:A])
    If r(1, 4) = w Then r(1, 4).Font.Color = vbRed 'colonne D
    If r(1, 5) = w Then r(1, 5).Font.Color = vbRed 'colonne E
    If r(1, 8) = w Then r(1, 8).Font.Color = vbRed 'colonne H
  Next
End If
'---colonnes F et G---
Set r = Intersect(Target, [F:G], UsedRange)
If Not r Is Nothing Then
  Set r = Intersect(r.EntireRow, [F:G]).Rows
  Intersect(r.EntireRow, [B:K]).Interior.ColorIndex = xlNone 'RAZ
  For Each r In Intersect(r.EntireRow, [F:G]).Rows
    If InStr(z, "," & r.Cells(2) & ",") Then
      If r.Cells(1) = x Then
        Intersect(r.EntireRow, [B:K]).Interior.Color = vbCyan
      ElseIf r.Cells(1) = y Then
        Intersect(r.EntireRow, [B:K]).Interior.Color = vbYellow
      End If
    End If
  Next
End If
End Sub

Edit 1 : j'ai remplacé la couleur Magenta par Yellow pour que "Unknow" reste visible.

Edit 2 : j'ai complété pour la recherche de "Unknow" en colonnes D E H où il y a des formules.

Pour tester sur 600 lignes j'ai copié la plage A2:K51 sur A2:K601 : la macro s'exécute en 0,16 s.

A+

job75 · 21 Septembre 2017

Re,

Je n'avais pas vu qu'en colonnes D E H il y a des formules.

J'ai donc modifié la macro précédente pour rechercher "Unknow" dans ces colonnes.

Cela ne change pratiquement pas la durée d'exécution.

A+

Nylream · 21 Septembre 2017

Merci beaucoup Job75,

Ça fonctionne, mais je me pose les questions suivantes du coup
Idéalement, j'aimerais que la couleur fassent la ligne entière, (nom compris).
Serait il possible d'avoir une mise en exergue pour doublon qui soit prioritaire, et supplante le code couleur de la ligne?

Dans un deuxième temps, je vais essayer d'ajouter d'autres conditions... malheureusement, j'en ai quelques unes : des O-6 et O-5, puis de O-4 à O-1 et O-C, ensuite de W-5 à W-1, et de E-9 à E-1. chaque suite de couleur différente et variant suivant Marine ou Navy. (comme pour O-11 à O-7).
Je testerais pour voir si j'ai compris par moi même déjà.

Encore merci pour ton aide

job75 · 21 Septembre 2017

Re,

Pour que le traitement des doublons soit prioritaire il suffit de le mettre à la fin :

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim w$, x$, y$, z$, r As Range, d As Object, P As Range
w = "Unknow": x = "Navy": y = "Marines": z = ",O-11,O-10,O-9,"
Application.ScreenUpdating = False
'---polices en colonnes B:K---
Set r = Intersect(Target, [B:C,F:G,I:K], UsedRange) 'en colonnes D E H il y a des formules
If Not r Is Nothing Then
  r.Font.ColorIndex = xlAutomatic 'RAZ
  For Each r In r
    If r = w Then r.Font.Color = vbRed
  Next
End If
Set r = Intersect(Target, [A:A], UsedRange)
If Not r Is Nothing Then
  Intersect(r.EntireRow, [D:E]).Font.ColorIndex = xlNone 'RAZ
  For Each r In r
    If r(1, 4) = w Then r(1, 4).Font.Color = vbRed 'colonne D
    If r(1, 5) = w Then r(1, 5).Font.Color = vbRed 'colonne E
  Next
End If
'---colonnes F et G---
Set P = Intersect(Target, [F:G], UsedRange)
If Not P Is Nothing Then
  Intersect(P.EntireRow, [B:K]).Interior.ColorIndex = xlNone 'RAZ
  For Each r In Intersect(P.EntireRow, [F:G]).Rows
    If InStr(z, "," & r.Cells(2) & ",") Then
      If r.Cells(1) = x Then
        Intersect(r.EntireRow, [B:K]).Interior.Color = vbCyan
      ElseIf r.Cells(1) = y Then
        Intersect(r.EntireRow, [B:K]).Interior.Color = vbYellow
      End If
    End If
  Next
  For Each r In Intersect(P.EntireRow, [A:A]) 'couleurs en colonne A
    If r.Interior.Color <> vbRed Then r.Interior.Color = r(1, 2).Interior.Color
  Next
End If
'---doublons en colonne A---
Set r = Intersect(Target, [A:A], UsedRange)
If Not r Is Nothing Then
  Set r = Intersect(Range("A2:A" & Rows.Count), UsedRange)
  r.Interior.ColorIndex = xlNone 'RAZ
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = vbTextCompare 'la casse est ignorée
  For Each r In r
    If d.exists(r.Value) Then
      Union(Cells(d(r.Value), 1), r).Interior.Color = vbRed
    Else
      If r <> "" Then d(r.Value) = r.Row 'mémorise la ligne
      If r(1, 2).Interior.ColorIndex <> xlNone Then r.Interior.Color = r(1, 2).Interior.Color 'si la ligne est colorée
    End If
  Next
End If
End Sub

Edit1 : j'ai ajouté la ligne de code :

Code:

      If r(1, 2).Interior.ColorIndex <> xlNone Then r.Interior.Color = r(1, 2).Interior.Color 'si la ligne est colorée

Edit 2 : pour les colonnes F et G j'ai séparé le traitement de la cellule en colonne A du reste de la ligne.

Pour les autres conditions sur les colonnes F:G je vous laisse faire, vous avez toutes les billes.

A+

Nylream · 21 Septembre 2017

Re bonjour Job75,

Petit bug avec une variable non défini apparemment

Merci pour ton aide,

job75 · 21 Septembre 2017

Re,

Nylream à dit:
Petit bug avec une variable non défini apparemment

Merci pour ton aide,

Quelle aide ? Dans tous mes codes toutes les variables sont définies.

A+

Nylream · 21 Septembre 2017

C'est bon, j'ai trouvé :

VB:

    If r(i, 4) = w Then r(1, 4).Font.Color = vbRed 'colonne D
    If r(i, 5) = w Then r(1, 5).Font.Color = vbRed 'colonne E
    If r(i, 8) = w Then r(1, 8).Font.Color = vbRed 'colonne H

Les i devaient être des 1, en comparant avec les autres codes que vous aviez envoyé, et grâce à option explicite, je m'en suis sortie.

Ça fonctionne,

Merci infiniment

job75 · 21 Septembre 2017

Re,

Ah oui, une stupide coquille et je n'avais pas mis Option Explicit ! Je corrige la macro précédente.

J'enlève aussi une ligne superflue dans le code des colonnes F:G.

A+

Effectuez une recherche sur Excel Downloads...

XL 2010 Mise en forme conditionnel [VBA] critères multiple

Nylream

XLDnaute Junior

Pièces jointes

Nylream

XLDnaute Junior

job75

XLDnaute Barbatruc

Bebere

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Nylream

XLDnaute Junior

Pièces jointes

Nylream

XLDnaute Junior

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Nylream

XLDnaute Junior

job75

XLDnaute Barbatruc

Nylream

XLDnaute Junior

job75

XLDnaute Barbatruc

Nylream

XLDnaute Junior

job75

XLDnaute Barbatruc

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums