XL 2010 Resolu par PMO2 et Lone Wolf : Blocage si saisie incomplète

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour à toutes et à tous,

Me revoilou devant un nouveau petit souci.
Malgré mes recherches, je n'ai pas trouvé la solution.

Voici ce qui m'amène :
Objectif (fichier test joint) :
si la cellule col "J" de la ligne en cours de saisie contient "1"
Interdire la saisie dans les cellules des autres lignes

Mon problème
Le code verrouille bien. Mais il bloque la saisie de la ligne en cours de saisie

Ma demande
Un code "bloquant" que si l'on clique hors de la ligne qui contient le "1" en col J.

J'espère être compréhensible LOL ;)
Un grand merci déjà d'avoir lu mon post.
Je vous souhaite une bonne journée à toutes et à tous,
Amicalement,
Lionel,
 

Pièces jointes

  • Test bloque qd change de ligne.xlsm
    20.4 KB · Affichages: 37
Dernière édition:

PMO2

XLDnaute Accro
Bonjour,
Essayez avec le code suivant
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim C As Range
'---
If Not Intersect(Target, Range("d7:h20")) Is Nothing Then
  For Each C In Range("j7:j20")
    If C = 1 Then
      If Target.Row <> C.Row Then
        Application.EnableEvents = False
        Range("d" & C.Row & "").Select
        Application.EnableEvents = True
        Exit Sub
      End If
    End If
  Next C
End If
End Sub
 

Pièces jointes

  • Test bloque qd change de ligne_pmo.xlsm
    18.7 KB · Affichages: 38

Lone-wolf

XLDnaute Barbatruc
Re Lionel

Essai N°2

VB:
Private Sub Worksheet_SelectionChange(ByVal R As Range)
Dim plage As Range, cel As Range

On Error Resume Next
Application.DisplayAlerts = False
If Not Intersect(R, Range("e7:e20")) Is Nothing And R.Count = 1 Then
If R.Offset(0, -1) <> "" Then R.Offset(0, 5) = 1
If Range(R.Offset(1, -1), R.Offset(1, 3)) <> "" Then
MsgBox "Vous ne pouvez pas modifier cette ligne", vbExclamation, "ATTENTION"
Application.Undo
Range(R.Offset(1, -1), R.Offset(1, 3)) = ""
End If
End If
End Sub
 

Lone-wolf

XLDnaute Barbatruc
Re

Erreur de ma part. Essai N°3

VB:
Private Sub Worksheet_SelectionChange(ByVal R As Range)
    Dim plage As Range, cel As Range

    On Error Resume Next
    Application.DisplayAlerts = False
    If Not Intersect(R, Range("e7:e20")) Is Nothing Then
        If R.Offset(0, -1) <> "" Then R.Offset(0, 5) = 1

        For Each cel In Range("e7:h20")
            If cel.Offset(0, 3) = "" And cel <> "" Then
                Range(cel.Offset(1, -1), cel.Offset(1, 3)) = ""
            Else
                Exit Sub
            End If
        Next cel
        Application.Goto R.Offset(-1, 3)
        MsgBox "Vous ne pouvez pas modifier cette ligne", vbExclamation, "ATTENTION"
    End If
End Sub
 

Lone-wolf

XLDnaute Barbatruc
Re

Essai N°4
VB:
Private Sub Worksheet_SelectionChange(ByVal R As Range)
    Dim plage As Range, cel As Range

    On Error Resume Next
    Application.DisplayAlerts = False
    If Not Intersect(R, Range("e7:e20")) Is Nothing Then
        For Each cel In Range("e7:h20")
            If R.Offset(0, -1) <> "" Then R.Offset(0, 5) = 1
            If R.Offset(-1, 3) = "" And cel <> "" Then
                MsgBox "Vous ne pouvez pas modifier cette ligne", vbExclamation, "ATTENTION"
                Range(ActiveCell.Offset(0, -1), ActiveCell.Offset(0, 3)) = ""
                 ActiveCell.Offset(0, 5) = ""
                Exit For
            End If
        Next cel
        If R.Offset(-1, -1) <> "" Then Exit Sub
    End If
End Sub
 

Lone-wolf

XLDnaute Barbatruc
Re à tous

Essaie N° 6. Lionel il faut mettre les entêtes en ligne 6.

VB:
Private Sub Worksheet_SelectionChange(ByVal R As Range)
    Dim plage As Range, cel As Range

    On Error Resume Next
    Application.DisplayAlerts = False
    If Not Intersect(R, Range("e7:e20")) Is Nothing Then
        For Each cel In Range("e7:h20")
            If R.Offset(0, -1) <> "" Then R.Offset(0, 5) = 1
            If ActiveCell.Offset(-1, 0) = "" Or ActiveCell.Offset(-1, 1) = "" Or _
             ActiveCell.Offset(-1, 2) = "" Or ActiveCell.Offset(-1, 3) = "" Then
                MsgBox "Vous ne pouvez pas modifier cette ligne", vbExclamation, "ATTENTION"
                Range(ActiveCell.Offset(0, -1), ActiveCell.Offset(0, 3)) = ""
                ActiveCell.Offset(0, 5) = ""
                Exit For
            End If
        Next cel
    End If
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 019
Membres
101 872
dernier inscrit
Colin T