5 mises en forme conditionnelles Fermé

Question

Bonjour, 

Ne connaissant pas du tout les macros ni le VBA, je souhaiterais savoir comment mettre en forme condtionnelle une plage de cellules selon le code suivant :
- si cellule=0 affichage de la cellule en gris
- si cellule=1 affichage en rouge
- si cellule=2 affichage en orange
- si cellule=3 affichage en vert
- si cellule=4 affichage en bleu

Ma matrice s'étend de G10 à DT210.

Merci d'avance pour toutes vos réponses.

Configuration: Windows 7 / Internet Explorer 8.0

f894009 · Answer

Bonjour,

Ouvrez votre classeur EXCEL, ensuite appuyez sur les touches Alt et F11 pour ouvrir le VBA. Double Click à gauche sur ThisWorkbook et copier le code ci-dessous dans la fenêtre qui s'est ouverte. Enregistrer. Revenez sur le classeur EXECEL. Essayez

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

  Cellule_Modifiee = Target.Address
  
  If Range(Cellule_Modifiee).Value = 0 Then
    Range(Cellule_Modifiee).Select
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
  ElseIf Range(Cellule_Modifiee).Value = 1 Then
    Range(Cellule_Modifiee).Select
    With Selection.Interior
        .ColorIndex = 3
        .Pattern = xlSolid
    End With
  ElseIf Range(Cellule_Modifiee).Value = 2 Then
    Range(Cellule_Modifiee).Select
    With Selection.Interior
        .ColorIndex = 45
        .Pattern = xlSolid
    End With
  ElseIf Range(Cellule_Modifiee).Value = 3 Then
    Range(Cellule_Modifiee).Select
    With Selection.Interior
        .ColorIndex = 4
        .Pattern = xlSolid
    End With
  ElseIf Range(Cellule_Modifiee).Value = 4 Then
    Range(Cellule_Modifiee).Select
    With Selection.Interior
        .ColorIndex = 41
        .Pattern = xlSolid
    End With
  Else
  
  End If

End Sub

Il n'y a pas le code pour tester que les cellules modifiées sont dans la plage de votre matrice.

Bonne continuation

f894009 · Answer

Rebonjour,

Remplacez le code par celui-ci


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

  Cellule_Modifiee = Target.Address
  
  If Range(Cellule_Modifiee).Value = 0 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 15
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
  ElseIf Range(Cellule_Modifiee).Value = 1 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 3
    With Selection.Interior
        .ColorIndex = 3
        .Pattern = xlSolid
    End With
  ElseIf Range(Cellule_Modifiee).Value = 2 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 45
    With Selection.Interior
        .ColorIndex = 45
        .Pattern = xlSolid
    End With
  ElseIf Range(Cellule_Modifiee).Value = 3 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 4
    With Selection.Interior
        .ColorIndex = 4
        .Pattern = xlSolid
    End With
  ElseIf Range(Cellule_Modifiee).Value = 4 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 41
    With Selection.Interior
        .ColorIndex = 41
        .Pattern = xlSolid
    End With
  Else
  
  End If

End Sub

lermite222 · Answer

Bonjour,
Si tu a Excel 2007 ou >, tu peu employer une Mise en forme conditionelle
A+

lermite222 · Answer

Mais si tu tient vraiment à le faire en VBA, un code  optimiser et avec détection d'erreur.  
Private Sub Worksheet_Change(ByVal Target As Range) 
    If Target.Count > 1 Then Exit Sub 'éviter les plantage quand sélectionne un bloc de cellule 
    If IsNumeric(Target) Then 
        With Target.Interior 
        Select Case Target 
        Case 0: .ColorIndex = 15 
        Case 1: .ColorIndex = 3 
        Case 2: .ColorIndex = 45 
        Case 3: .ColorIndex = 4 
        Case 4: .ColorIndex = 41 
        Case Else: .ColorIndex = xlNone
        End Select
        End With
    Else
        Target.Interior.ColorIndex = xlNone
    End If 
End Sub
En cas d'effacement changer le format de la cellule par du texte (une cellule vide étant assimilée à zéro) ou taper une apostrophe dans la cellule.
A+  
L'expérience instruit plus sûrement que le conseil. (André Gide)    
Si tu te cognes à un pot et que ça sonne creux, c'est pas forcément le pot qui est vide. ;-)(Confucius)

lermite222 · Answer

Si ta plage contient déja des données tu peu actualiser avec..   
Coller ce code dans le module de la feuille concernée.   
Sub Couleur()
Dim Cel As Range
    For Each Cel In Range("G10:DT210")
        If IsNumeric(Cel) Then
            With Cel.Interior
                Select Case Cel
                Case 0: .ColorIndex = 15
                Case 1: .ColorIndex = 3
                Case 2: .ColorIndex = 45
                Case 3: .ColorIndex = 4
                Case 4: .ColorIndex = 41
                End Select
            End With
        End If
    Next
End Sub

Mettre le curseur au milieu de la macro et taper F5   
A+   
L'expérience instruit plus sûrement que le conseil. (André Gide)     
Si tu te cognes à un pot et que ça sonne creux, c'est pas forcément le pot qui est vide. ;-)(Confucius)

Xymo · Answer

Ce genre de fonctionnalité est déjà intégrée à Excel, tu sélectionnes ta plage de cellules ( ici G10 à DT210 ) et après tu va dans Format > Mise en forme conditionnelle et là tu peux ajouter tes 5 conditions en spécifiant les couleurs pour chacune d'entre elles. Dans la liste choisis bien "égale à" . Voilà !

f894009 · Answer

Bonjour,

Ce code remet la couleur ou le manque de couleur

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  On Error Resume Next

  Cellule_Modifiee = Target.Address
  
  If Range(Cellule_Modifiee).Value = 0 And Not IsEmpty(Range(Cellule_Modifiee).Value) Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 15
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
  ElseIf Range(Cellule_Modifiee).Value = 1 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 3
    With Selection.Interior
        .ColorIndex = 3
        .Pattern = xlSolid
    End With
  ElseIf Range(Cellule_Modifiee).Value = 2 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 45
    With Selection.Interior
        .ColorIndex = 45
        .Pattern = xlSolid
    End With
  ElseIf Range(Cellule_Modifiee).Value = 3 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 4
    With Selection.Interior
        .ColorIndex = 4
        .Pattern = xlSolid
    End With
  ElseIf Range(Cellule_Modifiee).Value = 4 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 41
    With Selection.Interior
        .ColorIndex = 41
        .Pattern = xlSolid
    End With
  ElseIf IsEmpty(Range(Cellule_Modifiee)) Then
    Range(Cellule_Modifiee).Select
    Selection.Interior.ColorIndex = xlNone
    Selection.Font.ColorIndex = 0
  Else
  End If

End Sub

f894009 · Answer

Bonjour,
Ce code marche pour toutes les feuilles du classeur

lermite222 · Answer

Pour que ça fonctionne sur toutes les feuilles ou sur plusieur...
Supprimer les codes mis dans les modules des feuilles.
Mettre dans le module de ThisWorkbook...
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    'Si pas sur toutes les feuilles.. Sinon, enlever le 1er IF
    If Sh.Name = "Feuil1" Or Sh.Name = "Feuil2" Then
        If Target.Count > 1 Then Exit Sub 'éviter les plantage quand sélectionne un bloc de cellule
            If IsNumeric(Target) Then
            With Target.Interior
            Select Case Target
            Case 0: .ColorIndex = 15
            Case 1: .ColorIndex = 3
            Case 2: .ColorIndex = 45
            Case 3: .ColorIndex = 4
            Case 4: .ColorIndex = 41
            Case Else: .ColorIndex = xlNone
            End Select
            End With
        Else
            Target.Interior.ColorIndex = xlNone
        End If
    End If
End Sub
A+

f894009 · Answer

Re moi,

Ce code remplace le précédent et il fait la copie sur la feuil2, il faut enlever les formules que vous avez mises sur cette feuille

Dim x

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  Application.ScreenUpdating = False
  Cellule_Modifiee = Target.Address
  x = x + 1
  If x > 1 Then x = 0: Exit Sub ' pour éviter une boucle de 234
  
  If Range(Cellule_Modifiee).Value = 0 And Not IsEmpty(Range(Cellule_Modifiee).Value) Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 15
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    Selection.Copy
    Call Copie_Données(Cellule_Modifiee)
  ElseIf Range(Cellule_Modifiee).Value = 1 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 3
    With Selection.Interior
        .ColorIndex = 3
        .Pattern = xlSolid
    End With
    Selection.Copy
    Call Copie_Données(Cellule_Modifiee)
  ElseIf Range(Cellule_Modifiee).Value = 2 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 45
    With Selection.Interior
        .ColorIndex = 45
        .Pattern = xlSolid
    End With
    Selection.Copy
    Call Copie_Données(Cellule_Modifiee)
  ElseIf Range(Cellule_Modifiee).Value = 3 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 4
    With Selection.Interior
        .ColorIndex = 4
        .Pattern = xlSolid
    End With
    Selection.Copy
    Call Copie_Données(Cellule_Modifiee)
  ElseIf Range(Cellule_Modifiee).Value = 4 Then
    Range(Cellule_Modifiee).Select
    Selection.Font.ColorIndex = 41
    With Selection.Interior
        .ColorIndex = 41
        .Pattern = xlSolid
    End With
    Selection.Copy
    Call Copie_Données(Cellule_Modifiee)
  ElseIf IsEmpty(Range(Cellule_Modifiee)) Then
    Range(Cellule_Modifiee).Select
    Selection.Interior.ColorIndex = xlNone
    Selection.Font.ColorIndex = 0
    Selection.Copy
    Call Copie_Données(Cellule_Modifiee)
  Else
  End If
  Sheets("Feuil1").Select
  Application.CutCopyMode = False
End Sub

'Mise en forme feuil2
'--------------------
Sub Copie_Données(Cellule_Modifiee)
    Sheets("Feuil2").Select
    Range(Cellule_Modifiee).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
End Sub

5 mises en forme conditionnelles

10 réponses

Discussions similaires