Microsoft 365 Transformer des cellule en boutons

[jalaba]

Bonjour;
Je dois crée une grille d'audite et j'aimerais que les cellules soit des boutons sélectionnables calculant un score dans la case résultats.
Conforme: 3
Non conforme 0
Non évalué: 1
Non applicable 2

 

[sylvanu]

Bonjour Jalaba,
Je ne pense pas qu'il soit utile de créer des boutons. Voir en PJ.
Quand on clique sur une cellule contenant un des mots clé elle se met en vert et actualise Résultat.
Avec :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo Fin
    If Target.Count > 2 Then Exit Sub
    If Not Intersect(Target, Range("B1:E1000")) Is Nothing Then
        couleur = RGB(200, 225, 180) ' à modifier si besoin
        c = Target  ' transfert dans array car cellules fusionnées
        Range(Cells(Target.Row, "B"), Cells(Target.Row, "E")).Interior.Color = vbWhite
        Select Case c(1, 1)
            Case "Conforme"
                Target.Interior.Color = couleur
                Cells(Target.Row, "F") = 3
            Case "Non conforme"
                Target.Interior.Color = couleur
                Cells(Target.Row, "F") = 0
            Case "Non évalué"
                Target.Interior.Color = couleur
                Cells(Target.Row, "F") = 1
            Case "Non applicable"
                Target.Interior.Color = couleur
                Cells(Target.Row, "F") = 2
        End Select
    End If
Fin:
End Sub

 

[M12]

Bonjour,
J'ai mis des listes déroulantes pour le choix et une formule pour la somme
Les formules ne sont que dans la partie 1.0
A toi de continuer

 

[sylvanu]

Re Jalaba , bonjour M12,
Le même que le post #2 en reprenant les bonnes vieilles couleurs rouge, jaune, vert, gris souvent utilisées en audit dans ma boite. Plus parlant à mes yeux ( surtout pour les points Rouges )

 

[jalaba]

Bonjour Jalaba,
Je ne pense pas qu'il soit utile de créer des boutons. Voir en PJ.
Quand on clique sur une cellule contenant un des mots clé elle se met en vert et actualise Résultat.
Avec :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo Fin
    If Target.Count > 2 Then Exit Sub
    If Not Intersect(Target, Range("B1:E1000")) Is Nothing Then
        couleur = RGB(200, 225, 180) ' à modifier si besoin
        c = Target  ' transfert dans array car cellules fusionnées
        Range(Cells(Target.Row, "B"), Cells(Target.Row, "E")).Interior.Color = vbWhite
        Select Case c(1, 1)
            Case "Conforme"
                Target.Interior.Color = couleur
                Cells(Target.Row, "F") = 3
            Case "Non conforme"
                Target.Interior.Color = couleur
                Cells(Target.Row, "F") = 0
            Case "Non évalué"
                Target.Interior.Color = couleur
                Cells(Target.Row, "F") = 1
            Case "Non applicable"
                Target.Interior.Color = couleur
                Cells(Target.Row, "F") = 2
        End Select
    End If
Fin:
End Sub

Merci beaucoup pour votre aide

Bonjour Jalaba,
Je ne pense pas qu'il soit utile de créer des boutons. Voir en PJ.
Quand on clique sur une cellule contenant un des mots clé elle se met en vert et actualise Résultat.
Avec :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo Fin
    If Target.Count > 2 Then Exit Sub
    If Not Intersect(Target, Range("B1:E1000")) Is Nothing Then
        couleur = RGB(200, 225, 180) ' à modifier si besoin
        c = Target  ' transfert dans array car cellules fusionnées
        Range(Cells(Target.Row, "B"), Cells(Target.Row, "E")).Interior.Color = vbWhite
        Select Case c(1, 1)
            Case "Conforme"
                Target.Interior.Color = couleur
                Cells(Target.Row, "F") = 3
            Case "Non conforme"
                Target.Interior.Color = couleur
                Cells(Target.Row, "F") = 0
            Case "Non évalué"
                Target.Interior.Color = couleur
                Cells(Target.Row, "F") = 1
            Case "Non applicable"
                Target.Interior.Color = couleur
                Cells(Target.Row, "F") = 2
        End Select
    End If
Fin:
End Sub

Merci de votre aide

 

[jalaba]

Merci de votre aide