vide non autorisé dans cellule

[chaelie2015]

Bonjour forum

Dans la cellule fusionnée Je souhaite limité la saisie de 1 à 5 même le vide n’est pas autorisé .

Merci par avance

 

[job75]

Bonsoir chaelie2015,

La validation des données n'empêche pas l'effacement de la cellule, il faut du VBA :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range, autorise
Set cel = [C3] 'cellule à adapter
If Intersect(Target, cel) Is Nothing Then Exit Sub
autorise = Array("1", "2", "3", "4", "5") 'liste à adapter
With Application
    If IsError(.Match(CStr(cel), autorise, 0)) Then
        .EnableEvents = False
        .Undo 'annule les modifications
        .EnableEvents = True
    End If
End With
End Sub

A+

 

[chaelie2015]

Bonsoir job
merci pour la réponse; mais je souhaite avoir une formule si c'est possible?
merci par avance

 

[job75]

On ne peut pas à la fois modifier manuellement une cellule et y mettre une formule...

 

[chaelie2015]

D'accord, merci et bon week-end...

 

[JHA]

Bonjour à tous,

Un exemple avec validation des données mais cela ne gère pas le vide dans la cellule, peut-être inclure le vide dans les formules faisant référence à cette cellule.

JHA

 

[chaelie2015]

Bonjour à tous,

Un exemple avec validation des données mais cela ne gère pas le vide dans la cellule, peut-être inclure le vide dans les formules faisant référence à cette cellule.

JHA

Bonjour JHA
MERCI pour la réponse, je le sais, mais ce n'est pas ce que je cherchais.
a+

 

[job75]

Bonjour chaelie2015, JHA,

JHA, j'ai bien dit :

La validation des données n'empêche pas l'effacement de la cellule

Maintenant si l'on veut traiter une plage de plusieurs cellules (certaines fusionnées éventuellement) :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, autorise
Set r = [A2:D20] 'plage à adapter
Set r = Intersect(Target, r)
If r Is Nothing Then Exit Sub
autorise = Array("1", "2", "3", "4", "5") 'liste à adapter
With Application
    For Each r In r 'si entrées/effacements multiples
        If IsError(.Match(CStr(r.MergeArea(1)), autorise, 0)) Then
            .EnableEvents = False
            .Undo 'annule les modifications
            .EnableEvents = True
            Exit For
        End If
    Next
End With
End Sub

A+

 

[chaelie2015]

Bonjour chaelie2015, JHA,

JHA, j'ai bien dit :

Maintenant si l'on veut traiter une plage de plusieurs cellules (certaines fusionnées éventuellement) :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, autorise
Set r = [A2:D20] 'plage à adapter
Set r = Intersect(Target, r)
If r Is Nothing Then Exit Sub
autorise = Array("1", "2", "3", "4", "5") 'liste à adapter
With Application
    For Each r In r 'si entrées/effacements multiples
        If IsError(.Match(CStr(r.MergeArea(1)), autorise, 0)) Then
            .EnableEvents = False
            .Undo 'annule les modifications
            .EnableEvents = True
            Exit For
        End If
    Next
End With
End Sub

A+

Bonjour JOB
Encore une fois merci infenement pour cette réponse, mais je ne sais pas comment faire pour le recopie dans la meme fonction Private Sub Worksheet_Change qui existe dans mon fichier source:
le code qui existe (combiner entre les deux codes dans meme fonction):
Private Sub Worksheet_Change(ByVal R As Range)
Set R = Intersect(R, [M5,L23,L79,L135,L191,L247])
If R Is Nothing Then Exit Sub
For Each R In R 'si entrées/effacements multiples
If R.Row = 5 Then
Rows("6:10").Hidden = True
Rows("14:18").Hidden = True
Rows("5:" & R + 5).Hidden = False
Rows("13:" & R + 13).Hidden = False
[L79] = [L79]: [L135] = [L135]: [L191] = [L191]: [L247] = [L247]
Else
Rows(R.Row - 3 & ":" & R.Row + 52).Hidden = True
If [M5] > Int((R.Row - 23) / 56) Then
Rows(R.Row - 3 & ":" & R + R.Row + 1).Hidden = False
Rows(R.Row + 52).Hidden = False
End If
End If
Next
End Sub

plus le 2eme code objet de cette discussion :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, autorise
Set r = [M5:N5] 'plage à adapter
Set r = Intersect(Target, r)
If r Is Nothing Then Exit Sub
autorise = Array("1", "2", "3", "4", "5") 'liste à adapter
With Application
For Each r In r 'si entrées/effacements multiples
If IsError(.Match(CStr(r.MergeArea(1)), autorise, 0)) Then
.EnableEvents = False
.Undo 'annule les modifications
.EnableEvents = True
Exit For
End If
Next
End With
End Sub

MERCI PAR AVANCE
NB: juste pour rappelle merci pour les deux codes que tu m'as proposé

 

[job75]

Re,

Bah quel intérêt d'interdire l'effacement en M5 ?

C'est au contraire l'occasion d'afficher toutes les lignes :

Private Sub Worksheet_Change(ByVal R As Range)
Set R = Intersect(R, [M5,L23,L79,L135,L191,L247])
If R Is Nothing Then Exit Sub
For Each R In R 'si entrées/effacements multiples
    If R.Row = 5 Then
        If R = "" Then Rows.Hidden = False: Exit Sub 'affiche toutes les lignes
        Rows("6:10").Hidden = True
        Rows("14:18").Hidden = True
        Rows("5:" & R + 5).Hidden = False
        Rows("13:" & R + 13).Hidden = False
        [L23] = [L23]: [L79] = [L79]: [L135] = [L135]: [L191] = [L191]: [L247] = [L247]
    Else
        Rows(R.Row - 3 & ":" & R.Row + 52).Hidden = True
        If [M5] > Int((R.Row - 23) / 56) Then
            Rows(R.Row - 3 & ":" & R + R.Row + 1).Hidden = False
            Rows(R.Row + 52).Hidden = False
        End If
    End If
Next
End Sub

Fichier (de l'autre fil) joint.

A+

 

[chaelie2015]

Re,
merci pour la modif.
a+