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

[Usine à gaz]

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,

 

[Lone-wolf]

Bonjour Lionel 🙂

J'ai un sacré doute, mais enfin... . J'ai supprimer les formules et mis la condition dans la macro.

En PJ Essai N°1

 

[PMO2]

Bonjour,
Essayez avec le code suivant

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

 

[Usine à gaz]

Bonsoir Lone,
Merci d'être encore là 😉

En fait, c'est le contraire dont j'ai besoin.
Je voudrais qu'on ne puisse pas aller sur d'autres ligne tant que la ligne en cours n'est pas complètement renseignée de E à H si D contient une valeur (dans le test, c'est un n° de tel).

😕😕😛

 

[Lone-wolf]

Re Lionel

Essai N°2

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]

Re

Erreur de ma part. Essai N°3

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

 

[Usine à gaz]

Merci Lone pour ce nouvel essai.

ça bloque bien mais il faudrait pouvoir modifier la ligne en cours de saisie (voir photo jointe).
Je remet le fichier avec ton dernier code.
😉

 

[Lone-wolf]

Re

Essai N°4

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

 

[PMO2]

Le code que j'ai proposé dans le message #3 ne fait-il pas ce que vous demandez ?
(j'ai vu que vous l'avez complètement occulté dans votre dernière pièce jointe)

 

[Usine à gaz]

LOL, je vais tester 😉

 

[Usine à gaz]

Le code que j'ai proposé dans le message #3 ne fait-il pas ce que vous demandez ?
(j'ai vu que vous l'avez complètement occulté dans votre dernière pièce jointe)

Bonsoir, Je suis désolé, je n'avais pas vu votre réponse.
Un grand merci, je vais tester 🙂

 

[Lone-wolf]

PMO

Je viens de faire un test, et bein non, tu empêche la saisie de la ligne en dessous, or c'est si E7 à H7 = "" et non si J7 = 1, parce que Monsieur à changer de chemise 😉😀 Post #4.

 

[Lone-wolf]

Re à tous

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

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

 

[Usine à gaz]

Bonsoir, Je suis désolé, je n'avais pas vu votre réponse.
Un grand merci, je vais tester 🙂

Re PMO2,

Merci ça marche super bien et le petit dernier de Lone aussi.
Un grand merci à vous deux.
Bonne fin de journée 😉
Amicalement,
Lionel,

 

[Lone-wolf]

Re Lionel

Quel petit dernier?? 😵 . Et le code de PMO se base d'après ce que tu à mis dans la feuille et non sur ce que tu as dit au Post #4. 😛😀