Comment protéger plusieurs cellules fusionner après modification ?
Bonjour,
je suis bloqué depuis un moment sur un fichier excel et étant encore en "apprentissage" des VBA je patauge...
voici mon code actuel :
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("test")) Is Nothing Then Exit Sub
Me.Unprotect 1234
Target.Locked = True
Me.Protect 1234
End Sub
Donc mon fichier fonctionne, mais pas avec des cellules fusionnés...
Pouvez-vous me dire ce que je doit modifier pour que cela fonctionne SVP ?
(test= une plage de plusieurs cellule fusionné )
Merci !
Bonjour
A tester
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
If Intersect(Target, Range("test")) Is Nothing Then Exit Sub
Me.Unprotect 1234
For Each cell In Target
If Not cell.MergeCells Then
cell.Locked = True
Else
cell.MergeArea.Locked = True ' Verrouille la zone de cellules fusionnées
End If
Next cell
Me.Protect 1234
End Subc'est parfait, je suis outré de la facilité que vous avez a faire cela
Je doit l'associer a un autre code (qui fonctionne déjà) qui me permet de saisir sur une seul cellule plusieurs sélection d'une liste déroulante.(qui fait partie de ma sélection "test").
Le code :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Not Intersect(Target, Range("E10:E12:E14:E16:E18:E20:E22:E24:E26:C10:C12:C14:C16:C18:C20:C22:C24:C26:B10:B12:B14:B16:B18:B20:B22:B24:B26:M10:M12:M14:M16:M18:M20:M22:M24:M26:N10:N12:N14:N16:N18:N20:N22:N24:N26:P10:P12:P14:P16:P18:P20:P22:P24:P26")) Is Nothing Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue & ", ") > 0 Then
Target.Value = Replace(Oldvalue, Newvalue & ", ", "")
ElseIf InStr(1, Oldvalue, ", " & Newvalue) > 0 Then
Target.Value = Replace(Oldvalue, ", " & Newvalue, "")
ElseIf InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & ", " & Newvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
Comment je peux faire pour activé les deux macros simultanément ? je suis obligé de refaire un code avec les 2 codes fusionnés ?
Merci
Bonjour,
Dans ce cas il est utile de déplacer la logique de traitement dans des fonctions à part, et de garder le strict minimum dans worksheet_change : on y effectue simplement des test "d'orientation" un peu comme une gare routière : si telle condition, faire ceci, sinon cela.
Dans ce cas, on peut combiner le code de Joco avec le tien ainsi :
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Me.Range("test")) Is Nothing Then
HandleLockCells Target
End If
If Not Intersect(Target, Me.Range("E10:E12:E14:E16:E18:E20:E22:E24:E26," & _
"C10:C12:C14:C16:C18:C20:C22:C24:C26," & _
"B10:B12:B14:B16:B18:B20:B22:B24:B26," & _
"M10:M12:M14:M16:M18:M20:M22:M24:M26," & _
"N10:N12:N14:N16:N18:N20:N22:N24:N26," & _
"P10:P12:P14:P16:P18:P20:P22:P24:P26")) Is Nothing Then
HandleMultiSelect Target
End If
Application.EnableEvents = True
End Sub
' Verrouille les cellules modifiées dans la plage "test" // Joco
Private Sub HandleLockCells(ByVal targetRng As Range)
Me.Unprotect "1234"
Dim cell As Range
For Each cell In targetRng
If cell.MergeCells Then
cell.MergeArea.Locked = True
Else
cell.Locked = True
End If
Next cell
Me.Protect "1234"
End Sub
' Gère la sélection multiple dans les cellules avec validation // Maxou
Private Sub HandleMultiSelect(ByVal targetRng As Range)
If targetRng.SpecialCells(xlCellTypeAllValidation) Is Nothing Then Exit Sub
If targetRng.Value = vbNullString Then Exit Sub
Dim newValue As String, oldValue As String
newValue = targetRng.Value
Application.Undo
oldValue = targetRng.Value
Select Case True
Case oldValue = vbNullString
targetRng.Value = newValue
Case InStr(1, oldValue, newValue & ", ") > 0
targetRng.Value = Replace(oldValue, newValue & ", ", vbNullString)
Case InStr(1, oldValue, ", " & newValue) > 0
targetRng.Value = Replace(oldValue, ", " & newValue, vbNullString)
Case InStr(1, oldValue, newValue) = 0
targetRng.Value = oldValue & ", " & newValue
End Select
End SubNota : fonctionnalités internes non revues en détails.
Merci de votre intérêt pour ma problématique.
J'ai essayer votre code mais je crains que celui ci ne fonctionne pas. ( les cellules ne se verrouille pas après modification et je n'est pas la possibilité de sélectionné plusieurs choix )
Désoler de vous déranger pour cela.
re,
c'est quoi le but de cette plage, par exemple E11 est-elle une cellule de cette plage ?
Me.Range("E10:E12:E14:E16:E18:E20:E22:E24:E26," & _
"C10:C12:C14:C16:C18:C20:C22:C24:C26," & _
"B10:B12:B14:B16:B18:B20:B22:B24:B26," & _
"M10:M12:M14:M16:M18:M20:M22:M24:M26," & _
"N10:N12:N14:N16:N18:N20:N22:N24:N26," & _
"P10:P12:P14:P16:P18:P20:P22:P24:P26")cette plage c'est toute mes cellules ou se trouve une liste déroulante ( les cellules sont fusionnés, donc E11 fait partie de la cellule E10 )
c'est la même chose que "E10:E26,B10:C26,M10:N26,P10:P26"
Code a tester supprimer celui d'avant et remplacer par celui ci
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim rng As Range
' Définir la plage de cellules à surveiller
Set rng = Me.Range("E10:E12,E14,E16,E18,E20,E22,E24,E26," & _
"C10:C12,C14,C16,C18,C20,C22,C24,C26," & _
"B10:B12,B14,B16,B18,B20,B22,B24,B26," & _
"M10:M12,M14,M16,M18,M20,M22,M24,M26," & _
"N10:N12,N14,N16,N18,N20,N22,N24,N26," & _
"P10:P12,P14,P16,P18,P20,P22,P24,P26")
' Vérifier si la modification touche la plage spécifiée
If Intersect(Target, rng) Is Nothing Then Exit Sub
Me.Unprotect 1234
For Each cell In Target
If Not cell.MergeCells Then
cell.Locked = True
Else
cell.MergeArea.Locked = True ' Verrouille la zone de cellules fusionnées
End If
Next cell
Me.Protect 1234
End SubLe code ne fonctionne pas ( pas totalement ) car je peux toujours saisir une donné en cliquant sur ma liste déroulante mais celui ci se verrouille après le choix de 1 sélection.
Il faudrait que je puisse sélectionner plusieurs ligne de liste déroulante ( comme avec la code que j'ai mis précédemment ) et que la cellule se verrouille après que je sois sortie de la case.
Pour info dans ma plage "test" les cellule B,C,E sont des liste déroulante et les cellules A est une cellule vide a écrire.
Merci
A tester selon ce que j'ai compris
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim rng As Range
' Définir la plage de cellules à surveiller
Set rng = Me.Range("A10:A12,A14,A16,A18,A20,A22,A24,A26," & _
"E10:E12,E14,E16,E18,E20,E22,E24,E26," & _
"C10:C12,C14,C16,C18,C20,C22,C24,C26," & _
"B10:B12,B14,B16,B18,B20,B22,B24,B26," & _
"M10:M12,M14,M16,M18,M20,M22,M24,M26," & _
"N10:N12,N14,N16,N18,N20,N22,N24,N26," & _
"P10:P12,P14,P16,P18,P20,P22,P24,P26")
' Vérifier si la modification touche la plage spécifiée
If Intersect(Target, rng) Is Nothing Then Exit Sub
Me.Unprotect 1234
For Each cell In Target
' Si une cellule de la colonne A est modifiée
If Not Intersect(cell, Me.Range("A10:A12,A14,A16,A18,A20,A22,A24,A26")) Is Nothing Then
' Verrouiller les cellules correspondantes dans les colonnes B, C et E
cell.Offset(0, 1).Locked = True ' Colonne B
cell.Offset(0, 2).Locked = True ' Colonne C
cell.Offset(0, 4).Locked = True ' Colonne E
End If
' Si une cellule des colonnes B, C ou E est modifiée
If Not Intersect(cell, Me.Range("B10:B12,B14,B16,B18,B20,B22,B24,B26," & _
"C10:C12,C14,C16,C18,C20,C22,C24,C26," & _
"E10:E12,E14,E16,E18,E20,E22,E24,E26")) Is Nothing Then
' Si la cellule de la colonne A correspondante est remplie
If Not IsEmpty(cell.Offset(0, -1)) Then
cell.Locked = True
End If
End If
Next cell
Me.Protect 1234
End SubJ'ai adapter le code pour que toute les colonnes sois prise en compte ( vous comprendrez mieux ce que je veux faire ).
Et le code présente toujours une erreur, excel me met "La méthode 'range' de l'objet'_worksheet' a échoué". Ceci apparait depuis ma modification.
En mettant simplement votre code un autre message d'erreur était affiché qui est celui ci "Impossible de définir la propriété Locked de la classe Range."
Mon code modifier :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim rng As Range
' Définir la plage de cellules à surveiller
Set rng = Me.Range("A10:A12,A14,A16,A18,A20,A22,A24,A26," & _
"L10:L12,L14,L16,L18,L20,L22,L24,L26," & _
"E10:E12,E14,E16,E18,E20,E22,E24,E26," & _
"C10:C12,C14,C16,C18,C20,C22,C24,C26," & _
"B10:B12,B14,B16,B18,B20,B22,B24,B26," & _
"M10:M12,M14,M16,M18,M20,M22,M24,M26," & _
"N10:N12,N14,N16,N18,N20,N22,N24,N26," & _
"P10:P12,P14,P16,P18,P20,P22,P24,P26")
' Vérifier si la modification touche la plage spécifiée
If Intersect(Target, rng) Is Nothing Then Exit Sub
Me.Unprotect 1234
For Each cell In Target
' Si une cellule de la colonne A et L est modifiée
If Not Intersect(cell, Me.Range("A10:A12,A14,A16,A18,A20,A22,A24,A26,L10:L12,L14,L16,L18,L20,L22,L24,L26")) Is Nothing Then
' Verrouiller les cellules correspondantes dans les colonnes B, C et E
cell.Offset(0, 1).Locked = True ' Colonne B
cell.Offset(0, 2).Locked = True ' Colonne C
cell.Offset(0, 4).Locked = True ' Colonne E
cell.Offset(0, 7).Locked = True ' Colonne M
cell.Offset(0, 8).Locked = True ' Colonne N
cell.Offset(0, 10).Locked = True ' Colonne P
End If
' Si une cellule des colonnes B, C, E, M, N et P est modifiée
If Not Intersect(cell, Me.Range("B10:B12,B14,B16,B18,B20,B22,B24,B26," & _
"C10:C12,C14,C16,C18,C20,C22,C24,C26," & _
"E10:E12,E14,E16,E18,E20,E22,E24,E26," & _
"M10:M12,M14,M16,M18,M20,M22,M24,M26," & _
"N10:N12,N14,N16,N18,N20,N22,N24,N26," & _
"P10:P12,P14,P16,P18,P20,P22,P24,P26")) Is Nothing Then
' Si la cellule de la colonne A et L correspondante est remplie
If Not IsEmpty(cell.Offset(0, -1)) Then
cell.Locked = True
End If
End If
Next cell
Me.Protect 1234
End SubJe suis désoler car mes explication sont très mauvaise...(j'ai rajouter la colonne L qui correspond au A d'une deuxième page )( et M, N et P qui correspond au B, C et E d'une deuxieme page également ).
Merci
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim rng As Range
' Définir la plage de cellules à surveiller
Set rng = Me.Range("A10:A12,A14,A16,A18,A20,A22,A24,A26," & _
"L10:L12,L14,L16,L18,L20,L22,L24,L26," & _
"E10:E12,E14,E16,E18,E20,E22,E24,E26," & _
"C10:C12,C14,C16,C18,C20,C22,C24,C26," & _
"B10:B12,B14,B16,B18,B20,B22,B24,B26," & _
"M10:M12,M14,M16,M18,M20,M22,M24,M26," & _
"N10:N12,N14,N16,N18,N20,N22,N24,N26," & _
"P10:P12,P14,P16,P18,P20,P22,P24,P26")
' Vérifier si la modification touche la plage spécifiée
If Intersect(Target, rng) Is Nothing Then Exit Sub
Me.Unprotect 1234
For Each cell In Target
' Si une cellule de la colonne A et L est modifiée
If Not Intersect(cell, Me.Range("A10:A12,A14,A16,A18,A20,A22,A24,A26,L10:L12,L14,L16,L18,L20,L22,L24,L26")) Is Nothing Then
' Verrouiller les cellules correspondantes dans les colonnes B, C et E
cell.Offset(0, 1).Locked = True ' Colonne B
cell.Offset(0, 2).Locked = True ' Colonne C
cell.Offset(0, 4).Locked = True ' Colonne E
cell.Offset(0, 7).Locked = True ' Colonne M
cell.Offset(0, 8).Locked = True ' Colonne N
cell.Offset(0, 10).Locked = True ' Colonne P
End If
' Si une cellule des colonnes B, C, E, M, N et P est modifiée
If Not Intersect(cell, Me.Range("B10:B12,B14,B16,B18,B20,B22,B24,B26," & _
"C10:C12,C14,C16,C18,C20,C22,C24,C26," & _
"E10:E12,E14,E16,E18,E20,E22,E24,E26," & _
"M10:M12,M14,M16,M18,M20,M22,M24,M26," & _
"N10:N12,N14,N16,N18,N20,N22,N24,N26," & _
"P10:P12,P14,P16,P18,P20,P22,P24,P26")) Is Nothing Then
' Si la cellule de la colonne A et L correspondante est remplie
If Not IsEmpty(cell.Offset(0, -1)) Then
cell.Locked = True
End If
End If
Next cell
Me.Protect 1234
End SubJe suis désoler mais j'ai un message d'erreur me disant : "La méthode 'range' de l'objet'_Worksheet' a échoué"
(je n'est toucher a rien cette fois ci).
re,
c'est peut-être temps pour télécharger un fichier comme exemple ....
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim Isect1 As Range, Isect2 As Range
' Définir la plage de cellules à surveiller
Set Isect1 = Intersect(Target, Me.Range("A10:A26,L10:L26")) 'cellules modifiées dans A&L
Set Isect2 = Intersect(Target, Me.Range("B10:C26,E10:E26,M10:N26,P10:P26")) 'cellules modifiées dans B,C,E,M,N&P
If Isect1 Is Nothing And Isect1 Is Nothing Then Exit Sub 'rien modfiées dans ces plages= exit
Me.Unprotect 1234
If Not Isect1 Is Nothing Then 'modifications dan A&L
For Each c In Isect1.Cells
If c.MergeArea.Cells(1).Address = c.Address Then
c.Offset(, 2 - c.Column).Locked = True ' Colonne B
c.Offset(, 3 - c.Column).Locked = True ' Colonne C
c.Offset(, 5 - c.Column).Locked = True ' Colonne E
c.Offset(, 13 - c.Column).Locked = True ' Colonne M
c.Offset(, 14 - c.Column).Locked = True ' Colonne N
c.Offset(, 16 - c.Column).Locked = True ' Colonne P
End If
Next
End If
' Si une cellule des colonnes B, C, E, M, N et P est modifiée
If Not Isect2 Is Nothing Then 'modifications dans B,C,E,M,N&P
For Each c In Isect2.Cells
If Not IsEmpty(c.Offset(, 1 - c.Column)) And Not IsEmpty(c.Offset(, 12 - c.Column)) Then c.Locked = True ' Si A&L rempli et cellule modifiée = cellule "locked"
Next
End If
Me.Protect 1234
End SubRe,
Votre code me met le même message d'erreur en surlignant la ligne :
c.Offset(, 2 - c.Column).Locked = True ' Colonne Bde plus ni la sélection multiple ni le blocage de cellule après modification ne fonctionne.
J'aurais aimer vous envoyer le fichier car effectivement cela aurait été beaucoup plus simple or ce fichier est a utilisation professionnel et contient des données sensible.
Je vous ferait un autre fichier vide dans la semaine comme exemple car c'est difficile d'imaginer sans le fichier sous les yeux.
Merci pour votre aide.
re,
c'est peut-être temps pour télécharger un fichier comme exemple ....
Je suppose que vos cellules fusionnées causent les problèmes et je ne comprends pas ce qu'on doit faire si on change oubien A oubien L ? C'est la même chose ou pas ?
Oui les cellules A et L sont les mêmes et les cellules B,C,E,M,N et P sont également identique.
Je vous télécharge un exemple de fichier dans la semaine.
Merci