Discussion :

[Invité]

Bonjour à vous tous,

Je sollicite votre aide car mon code ne fonctionne pas du tout et en plus il me semble qu'il y aurait une façon plus simple d'y arriver.

Ce que je cherche à faire, je le fais déjà avec mise en forme conditionnelle, mais je suis rendu déjà rendu à 4 choix de couleur.

si(a1)=1;mettre(A1:A3)de tel couleur;si(a1)=2;mettre(A1:A3)de tel couleur;..etc.

J'ai dans mon tableau 17 casé qui peut changer de valeur et ceux-ci provient d'une autre feuille ça risque d'être d'une longueur excessif.
Voici le code que j'ai pensé mais comme je vous dis il ne fonctionne pas correctement.

Merci de votre aide.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Sub worksheet_change(ByVal target As Range)
    If Not Intersect(target, Range("a1")) Is Nothing Then
On Error Resume Next
    If Worksheets(1).Range.Value("a1") = "Vac" _
    Then Worksheets(1).Range("a1:a3").Interior.ColorIndex = 1
    If Worksheets(1).Range.Value("a1") = "For" _
    Then Worksheets(1).Range("a1:a3").Interior.ColorIndex = 2
    If Worksheets(1).Range.Value("a1") = "Pre" _
    Then Worksheets(1).Range("a1:a3").Interior.ColorIndex = 3
    If Worksheets(1).Range.Value("a1") = "Mal" _
    Then Worksheets(1).Range("a1:a3").Interior.ColorIndex = 4
ElseIf Not Intersect(target, Range("b1")) Is Nothing Then
    If Worksheets(1).Range.Value("b1") = "Vac" _
    Then Worksheets(1).Range("b1:b3").Interior.ColorIndex = 1
    If Worksheets(1).Range.Value("b1") = "For" _
    Then Worksheets(1).Range("b1:b3").Interior.ColorIndex = 2
    If Worksheets(1).Range.Value("b1") = "Pre" _
    Then Worksheets(1).Range("b1:b3").Interior.ColorIndex = 3
    If Worksheets(1).Range.Value("b1") = "Mal" _
    Then Worksheets(1).Range("b1:b3").Interior.ColorIndex = 4
ElseIf Not Intersect(target, Range("c1")) Is Nothing Then
    If Worksheets(1).Range.Value("c1") = "Vac" _
    Then Worksheets(1).Range("c1:c3").Interior.ColorIndex = 1
    If Worksheets(1).Range.Value("c1") = "For" _
    Then Worksheets(1).Range("c1:c3").Interior.ColorIndex = 2
    If Worksheets(1).Range.Value("c1") = "Pre" _
    Then Worksheets(1).Range("c1:c3").Interior.ColorIndex = 3
    If Worksheets(1).Range.Value("c1") = "Mal" _
    Then Worksheets(1).Range("c1:c3").Interior.ColorIndex = 4
ElseIf Not Intersect(target, Range("d1")) Is Nothing Then
    If Worksheets(1).Range.Value("d1") = "Vac" _
    Then Worksheets(1).Range("d1:d3").Interior.ColorIndex = 1
    If Worksheets(1).Range.Value("d1") = "For" _
    Then Worksheets(1).Range("d1:d3").Interior.ColorIndex = 2
    If Worksheets(1).Range.Value("d1") = "Pre" _
    Then Worksheets(1).Range("d1:d3").Interior.ColorIndex = 3
    If Worksheets(1).Range.Value("d1") = "Mal" _
    Then Worksheets(1).Range("d1:d3").Interior.ColorIndex = 4
End If
End Sub

[Theze]

Bonjour,

Teste ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
 
Sub worksheet_change(ByVal target As Range)
 
    With Worksheets(1)
 
        Select Case target.Address(0, 0)
 
            Case "A1"
 
                If .[A1] = "Vac" Then .[A1:A3].Interior.ColorIndex = 1
                If .[A1] = "For" Then .[A1:A3].Interior.ColorIndex = 2
                If .[A1] = "Pre" Then .[A1:A3].Interior.ColorIndex = 3
                If .[A1] = "Mal" Then .[A1:A3].Interior.ColorIndex = 4
 
            Case "B1"
 
                If .[B1] = "Vac" Then .[B1:B3].Interior.ColorIndex = 1
                If .[B1] = "For" Then .[B1:B3].Interior.ColorIndex = 2
                If .[B1] = "Pre" Then .[B1:B3].Interior.ColorIndex = 3
                If .[B1] = "Mal" Then .[B1:B3].Interior.ColorIndex = 4
 
            Case "C1"
 
                If .[C1] = "Vac" Then .[C1:C3].Interior.ColorIndex = 1
                If .[C1] = "For" Then .[C1:C3].Interior.ColorIndex = 2
                If .[C1] = "Pre" Then .[C1:C3].Interior.ColorIndex = 3
                If .[C1] = "Mal" Then .[C1:C3].Interior.ColorIndex = 4
 
            Case "D1"
 
                If .[D1] = "Vac" Then .[D1:D3].Interior.ColorIndex = 1
                If .[D1] = "For" Then .[D1:D3].Interior.ColorIndex = 2
                If .[D1] = "Pre" Then .[D1:D3].Interior.ColorIndex = 3
                If .[D1] = "Mal" Then .[D1:D3].Interior.ColorIndex = 4
 
        End Select
 
    End With
 
End Sub

Hervé.

[Guiiand]

Bonjour,

Voila qui devrait répondre à tes attentes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub worksheet_change(ByVal Target As Range)
 
Dim NoColonne As Integer
 
    If Not Intersect(Target, Range("A1:D1")) Is Nothing Then
 
        NoColonne = Target.Column
 
        With Sheets("Nom de la feuille")
 
            Select Case .Range(Cells(1, NoColonne)).Text
                Case "Vac"
                    .Range(Cells(1, NoColonne), Cells(3, NoColonne)).Interior.ColorIndex = 1
                Case "For"
                    .Range(Cells(1, NoColonne), Cells(3, NoColonne)).Interior.ColorIndex = 2
                Case "Pre"
                    .Range(Cells(1, NoColonne), Cells(3, NoColonne)).Interior.ColorIndex = 3
                Case "Mal"
                    .Range(Cells(1, NoColonne), Cells(3, NoColonne)).Interior.ColorIndex = 4
            End Select
 
        End With
 
    End If
 
End Sub

Tu peux rajouter des case si tu as besoins, ou agrandir le champs de détection

Bonne journée

[mercatog]

Bonjour à tous
J'ajoute une autre aux différentes propositions

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Private Sub Worksheet_Change(ByVal Target As Range)
 
If InStr("A1 B1,C1, D1", Target.Address(0, 0)) Then Couleur Target
End Sub
 
Private Sub Couleur(ByVal Rng As Range)
Dim Kl As Integer
 
Select Case UCase(Rng.Value)
    Case "VAC": Kl = 1
    Case "FOR": Kl = 2
    Case "PRE": Kl = 3
    Case "MAL": Kl = 4
    Case Else: Kl = xlNone
End Select
Rng.Resize(3, 1).Interior.ColorIndex = Kl
End Sub

[Invité]

Merci à vous tous d'avoir pris le temps de m'aider et c'est grandement apprécié, je test le tous ce soir et je vous redonne des nouvelles bientôt.

Merci.

[Theze]

Bonsoir,

Une autre possibilité avec Switch :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
 
Sub worksheet_change(ByVal Target As Range)
 
    If Not Intersect(Target, Union([A1], [B1], [C1], [D1])) Is Nothing Then
 
        Target.Resize(3, 1).Interior.ColorIndex = Switch(Target = "Vac", 1, Target = "For", 2, Target = "Pre", 3, Target = "Mal", 4)
 
    End If
 
End Sub

Hervé.

[Invité]

Bonjour à tous,
Merci pour vos réponse.

La macro fonctionne bien, mais la mise à jour ne se fait pas, probablement dû au fait que l'information de la cellule provient d'une autre feuille.

Avez-vous une idée ou une solution ?

[Theze]

Bonjour,

A mettre dans le module du classeur et à adapter :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    'à adapter...
    'si la saisie n'est pas faite dans la feuille "Feuil1", fin
    If Sh.Name <> "Feuil1" Then Exit Sub
 
    'la mise en couleur des cellules ce fait dans "Feuil2"
    If Not Intersect(Target, Union([A1], [B1], [C1], [D1])) Is Nothing Then
 
        Worksheets("Feuil2").Range(Target.Address).Resize(3, 1).Interior.ColorIndex = Switch(Target = "Vac", 1, Target = "For", 2, Target = "Pre", 3, Target = "Mal", 4)
 
    End If
 
End Sub

Hervé.