La validation des données n'empêche pas l'effacement de la cellule, il faut du VBA :
Code:
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
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.
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.
Maintenant si l'on veut traiter une plage de plusieurs cellules (certaines fusionnées éventuellement) :
Code:
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
Maintenant si l'on veut traiter une plage de plusieurs cellules (certaines fusionnées éventuellement) :
Code:
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
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é
C'est au contraire l'occasion d'afficher toutes les lignes :
Code:
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