Discussion :

[jupax06]

Bonjour à tous,

J'aimerai optimiser le code d'une fonctionnalité de mon fichier: changer le fond d'une plage de cellule quand une cellule de la plage est sélectionnée...

J'ai un questionnaire qui peut comporter plusieurs questions et sous-questions (avec un nombre de réponse qui est être variable). Quand l'utilisateur a fait son choix il clique sur une réponse et la cellule (plage) change de fond, cela afin de voir au premier coup d'oeil le choix de l'utilisateur.

Et cela pour toutes les questions et sous-questions.

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
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
Const DEBUT_REP_QA1 As Integer = 3
Const FIN_REP_QA1 As Integer = 6
Const DEBUT_REP_QA2 As Integer = 8
Const FIN_REP_QA2 As Integer = 12
 
m_row = Target.Row
m_col = Target.Column
 
If m_col >= 1 And m_col <= 2 Then
    'Question A-1
    If m_row >= DEBUT_REP_QA1 And m_row <= FIN_REP_QA1 Then
        If Cells(m_row, m_col).Value <> "" Then
            'Le fond devient blanc
            Range(Cells(DEBUT_REP_QA1, 1), Cells(FIN_REP_QA1, 2)).Columns.Interior.ThemeColor = xlThemeColorDark1
 
            'Le fond devient gris
            Range(Cells(m_row, 1), Cells(m_row, 2)).Columns.Interior.ThemeColor = xlThemeColorAccent3
        End If
    End If
 
    'Question A-2
    If m_row >= DEBUT_REP_QA2 And m_row <= FIN_REP_QA2 Then
        If Cells(m_row, m_col).Value <> "" Then
            'Le fond devient blanc
            Range(Cells(DEBUT_REP_QA2, 1), Cells(FIN_REP_QA2, 2)).Columns.Interior.ThemeColor = xlThemeColorDark1
 
            'Le fond devient gris
            Range(Cells(m_row, 1), Cells(m_row, 2)).Columns.Interior.ThemeColor = xlThemeColorAccent3
        End If
    End If
End If
End Sub

Le code ci-dessus montre bien le problème que j'ai actuellement... la redondance du code.

A noter que les plages des réponses ne sont pas contiguës...

J'ai essayé divers solutions (boucle, tableau) mais comme je suis nouveau en VBA je ne suis pas parvenu à la trouver.

Je joins également mon fichier (questionnaire_Dev.xlsm), en espérant que quelqu'un trouvera une solution à mon problème.

Merci d'avance

[Invité]

Bonjour,

En supposant que les aires de vos questionnaires soient nommées : QuestionnaireA1, QuestionnaireA2,....

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
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
        If Target.Count > 1 Then Exit Sub
 
         With Union(Range("QuestionnaireA1"), Range("QuestionnaireA2"), Range("QuestionnaireA31"), Range("QuestionnaireA32"))
            .Interior.ThemeColor = xlThemeColorDark1
        End With
 
        If Not Intersect(Target, Range("QuestionnaireA1")) Is Nothing Then
           Range(Cells(Target.Row, 1), Cells(Target.Row, 2)).Interior.ThemeColor = xlThemeColorAccent3
        End If
 
        If Not Intersect(Target, Range("QuestionnaireA2")) Is Nothing Then
           Range(Cells(Target.Row, 1), Cells(Target.Row, 2)).Interior.ThemeColor = xlThemeColorAccent3
        End If
 
        If Not Intersect(Target, Range("QuestionnaireA31")) Is Nothing Then
           Range(Cells(Target.Row, 1), Cells(Target.Row, 2)).Interior.ThemeColor = xlThemeColorAccent3
        End If
 
        If Not Intersect(Target, Range("QuestionnaireA32")) Is Nothing Then
           Range(Cells(Target.Row, 1), Cells(Target.Row, 2)).Interior.ThemeColor = xlThemeColorAccent3
        End If
 
End Sub

Le fichier joint contient un deuxième onglet qui met les lignes du questionnaire à la couleur du titre de la question :

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
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
        If Target.Count > 1 Then Exit Sub
 
        With Union(Range("QuestionnaireA1"), Range("QuestionnaireA2"), Range("QuestionnaireA31"), Range("QuestionnaireA32"))
            .Interior.ThemeColor = xlThemeColorDark1
            .Font.ColorIndex = xlAutomatic
        End With
 
        If Not Intersect(Target, Range("QuestionnaireA1")) Is Nothing Then
           With Range(Cells(Target.Row, 1), Cells(Target.Row, 2))
                .Interior.Color = Range("TitreA1").Interior.Color
                .Font.Color = Range("TitreA1").Font.Color
           End With
        End If
 
        If Not Intersect(Target, Range("QuestionnaireA2")) Is Nothing Then
           With Range(Cells(Target.Row, 1), Cells(Target.Row, 2))
                .Interior.Color = Range("TitreA2").Interior.Color
                .Font.Color = Range("TitreA2").Font.Color
           End With
        End If
 
        If Not Intersect(Target, Range("QuestionnaireA31")) Is Nothing Then
          With Range(Cells(Target.Row, 1), Cells(Target.Row, 2))
                .Interior.Color = Range("TitreA31").Interior.Color
                .Font.Color = Range("TitreA31").Font.Color
           End With
        End If
 
        If Not Intersect(Target, Range("QuestionnaireA32")) Is Nothing Then
            With Range(Cells(Target.Row, 1), Cells(Target.Row, 2))
                .Interior.Color = Range("TitreA32").Interior.Color
                .Font.Color = Range("TitreA32").Font.Color
           End With
        End If
 
End Sub

Pièce jointe 204605

Cordialement.

[Invité]

Il y avait plus simple pour la première proposition :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
        If Target.Count > 1 Then Exit Sub
 
         With Union(Range("QuestionnaireA1"), Range("QuestionnaireA2"), Range("QuestionnaireA31"), Range("QuestionnaireA32"))
            .Interior.ThemeColor = xlThemeColorDark1
        End With
 
        If Not Intersect(Target, Union(Range("QuestionnaireA1"), Range("QuestionnaireA2"), Range("QuestionnaireA31"), Range("QuestionnaireA32"))) Is Nothing Then
           Range(Cells(Target.Row, 1), Cells(Target.Row, 2)).Interior.ThemeColor = xlThemeColorAccent3
        End If
 
End Sub

Cordialement.

[jupax06]

Bonjour Eric,

Merci beaucoup cela fonctionne très bien !! C'est sympa d'avoir fait une version en couleur

Cependant, j'aurai souhaité que lorsque l'on sélectionne une réponse, celle-ci reste en gris, même si l'on passe à une autre question.
Car actuellement, si je répond à la question A-2 après avoir répondu à la question A-1, on ne voit plus le choix de la question A-1 (redevenu blanc).

Est-ce que vous voyez ce que je veux dire ?

Cordialement

[Invité]

Cependant, j'aurai souhaité que lorsque l'on sélectionne une réponse, celle-ci reste en gris, même si l'on passe à une autre question.
Car actuellement, si je répond à la question A-2 après avoir répondu à la question A-1, on ne voit plus le choix de la question A-1 (redevenu blanc).

Pièce jointe 204699

Cordialement.

[jupax06]

C'est parfait, merci beaucoup