Case à choix multiple pour certaines et unique pour d'autres

Bonjour,

Dans le meme tableau, je souhaite un code VBA pour rendre certaines cases à choix unique et d'autres cases à choix multiple.

Dans les deux cas, à chaque fois que la personne écrit quelque chose voir meme un espace, cela se tranforme en X.

Le fichier Excel vous aidera peut etre à mieux comprendre ma demande.

Par avance, un grand merci pour votre aide.

Bonjour,

un essai

bonjour

voici un autre essai ; avec une touche de vba ( hé oui .........)

dis -donc Niko , tu t'es pas trop foulé pour ton avatar ; avoue qu'il est bien et, qu'il t'a plu

cordialement

Bonjour et merci pour ton aide.

Ce n'est pas encore tout a fait cela. OK pour les cellules B8 à B11 en revanche sur les cellules B2 à B4, il faudrait qu'au moment où l'on saisie B3, cela efface en plus le X de B2 ou B4 automatiquement.

Mille merci.

Bonjour,

@ RAF, fichier modifier en pièce jointe.

@ Tulipe, Hé, mon Avatar te plaît? Non je ne me suis pas foulé mais parfois les choses simples sont parfois les meilleurs, comme moi

bonjour

voici une deuxieme version (non sans mal )

question pour les pros: pourquoi l'utilisation d'une procedure vba annule l'utilisation de validation >>perso>>la formule : nb.si( plag;critere)=1 ; j'avais fait un mixt : vba pour les "x" et validation pour limiter le nb de X

merci

cordialement

Merci Tulipe 4.

Mais le fichier ne fonctionne pas comme je le souhaite.

Est ce que quelqu'un peux faire quelchose à partir de ce code (qui traite les cellules B2 à B4 mais pas les autres à choix multiple) ?

If Not Intersect(Target, [B2,B3,B4]) Is Nothing Then

Application.EnableEvents = False

[B2,B3,B4].ClearContents

Target = "X"

Application.EnableEvents = True

Merci de votre aide.

Quelqu'un pour m'aider ?

Merci.

Bonjour,

Avec VBA et mettre le code dans le module de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, [B2:B4]) Is Nothing Then

        Application.EnableEvents = False

        [B2:B4].ClearContents
        Target = "X"

        Application.EnableEvents = True

    End If

    If Not Intersect(Target, [B8:B11]) Is Nothing Then Target = "X"

End Sub

Hervé.

Merci Theze

J'ai un message d'erreur qui apparait lors de l'utilisation du fichier : Erreur d'exécution '28' Espace pile insuffisant

Quezaco ?

Re,

Essai comme ça :

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, [B2:B4]) Is Nothing Then

        Application.EnableEvents = False

        [B2:B4].ClearContents
        Target = "X"

        Application.EnableEvents = True

    End If

    If Not Intersect(Target, [B8:B11]) Is Nothing Then

        Application.EnableEvents = False

        Target = "X"

        Application.EnableEvents = True

    End If

End Sub

Hervé.

bonjour

en version "light"

cordialement

Merci à vous deux de votre aide.

Le code de Theze est plus approprié à ce que je recherche.

Il demeure cependant un petit bug, toujours dans la plage de cellule B8:B11, une fois que j'ai tapé quelque chose et que ca s'est transformé en X, je ne peux plus effacer la cellule. Il faudrait que si je retourne dans la cellule et que je supprime cette case, le X s'efface.

Par avance merci pour cet ajustement.

Bonjour

Vois une solution alternative en utilisant le double click dans la cellule avec ce code

Dim ok As Boolean
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If ok = True Then Exit Sub
If Not Intersect(Target, Range("B2:B4")) Is Nothing Then
    Cancel = False
    ok = True
    If Target = "X" Then Target.ClearContents Else: Target = "X"
    ok = False
    End If

If Not Intersect(Target, Range("B8:B11")) Is Nothing Then
    Cancel = False
    ok = True
    If Target = "X" Then Target.ClearContents Else: Target = "X"
    ok = False
    End If
Cancel = True
End Sub

Si ok, clique sur le V vert à coté du bouton EDITER pour cloturer le fil

Amicalement

Edit Dan :

Oups je viens de relire ta demande dans le fichier. essaie ceci

Dim ok As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
If ok = True Then Exit Sub
If Not Intersect(Target, Range("B2:B4")) Is Nothing Then
    ok = True
    If Target > "" Then Target = "X" Else: Target.ClearContents
    ok = False
    End If

If Not Intersect(Target, Range("B8:B11")) Is Nothing Then
    ok = True
    If Target > "" Then Target = "X" Else: Target.ClearContents
    ok = False
    End If
End Sub

Re,

Avec la possibilité de vider les cellules dans les deux zones :

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, [B2:B4]) Is Nothing Then

        Application.EnableEvents = False

        If Target <> "" Then

            [B2:B4].ClearContents
            Target = "X"

        End If

        Application.EnableEvents = True

    End If

    If Not Intersect(Target, [B8:B11]) Is Nothing Then

        Application.EnableEvents = False

        If Target <> "" Then Target = "X"

        Application.EnableEvents = True

    End If

End Sub

Hervé.

Merci.

Vous etes des kings !

Ca fonctionne super.