Problème de protection lors de copie avec macro
Résolu
bassmart
Messages postés
281
Date d'inscription
Statut
Membre
Dernière intervention
-
bassmart Messages postés 281 Date d'inscription Statut Membre Dernière intervention -
bassmart Messages postés 281 Date d'inscription Statut Membre Dernière intervention -
Bonjour à tous!
J'ai un petit problème avec une macro qui se lance en double-cliquant sur une cellule de la colonne "C" de ma feuille générale (Coordonnées).
Cette macro sert à modifier la valeur de la cellule sélectionné. Elle recherche la valeur de la cellule avant modification(original) dans les autres feuilles de mon fichier et lorsqu'elle la trouve, elle la remplace par la nouvelle valeur entrée dans l'InputBox.
Mon fichier contient 1 feuille générale et 4 autres feuilles pour chacun de mes types de sondages qui se classe selon la première lettre du sondage.
Mon problème est que mes feuilles sont toutes protégés! Donc, quand il veux remplacer la valeur dans la bonne feuille, ça ne fonctionne pas.
J'ai essayé d'ajouter la fonction Activesheet.Unprotect à plusieurs endroit mais sans succès pour le moment, parce que ça déprotège ma feuille "Coordonnées" et non pas une des autres feuilles.
Voici mon code:
Voici mon fichier:
https://www.cjoint.com/?0DipTOn2Z5r
Pouvez vous m'aider sur celle là?!
Merci!
J'ai un petit problème avec une macro qui se lance en double-cliquant sur une cellule de la colonne "C" de ma feuille générale (Coordonnées).
Cette macro sert à modifier la valeur de la cellule sélectionné. Elle recherche la valeur de la cellule avant modification(original) dans les autres feuilles de mon fichier et lorsqu'elle la trouve, elle la remplace par la nouvelle valeur entrée dans l'InputBox.
Mon fichier contient 1 feuille générale et 4 autres feuilles pour chacun de mes types de sondages qui se classe selon la première lettre du sondage.
Mon problème est que mes feuilles sont toutes protégés! Donc, quand il veux remplacer la valeur dans la bonne feuille, ça ne fonctionne pas.
J'ai essayé d'ajouter la fonction Activesheet.Unprotect à plusieurs endroit mais sans succès pour le moment, parce que ça déprotège ma feuille "Coordonnées" et non pas une des autres feuilles.
Voici mon code:
Private dlig As Long
Private PL As Range
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim nvalue As String
Dim NewVal As Variant
Dim f As Worksheet
Dim valueRange As Range
Dim Cpt As Integer
Application.ScreenUpdating = False
nvalue = ActiveCell.Value
If Not Intersect(Target, Range("c5:c" & [a1048576].End(xlUp).Row + 1)) Is Nothing Then
If MsgBox("Voulez-vous mofifier le numéro de ce sondage?", _
vbYesNo + vbQuestion, "MODIFER") = vbYes Then
NewVal = UCase(InputBox("Nouveau numéro de sondage?", "MODIFICATION DE NUMÉRO"))
If NewVal = "" Then
ActiveCell.Offset(-1, 0).Select
Exit Sub
Else
ActiveCell = NewVal
End If
If InStr(1, nvalue, "C") = 1 Or InStr(1, nvalue, "M") = 1 Then
Set valueRange = Sheets("CPTU").Columns(1)
ElseIf InStr(1, nvalue, "F") = 1 Then
Set valueRange = Sheets("FORAGE").Columns(1)
ElseIf InStr(1, nvalue, "Z") = 1 Or InStr(1, nvalue, "FZ") = 1 Then
Set valueRange = Sheets("Piézomètres").Columns(2)
ElseIf InStr(1, nvalue, "I") = 1 Then
Set valueRange = Sheets("Inclinomètres").Columns(2)
Else
Set valueRange = Nothing
MsgBox "La valeur n'a pas été trouvé dans les autres feuilles! Mettre à jours les feuillets sur la page d'accueil!", vbCritical
End If
If Not valueRange Is Nothing Then
valueRange.Replace nvalue, NewVal, lookat:=xlWhole, searchorder:=xlByColumns
End If
If NewVal <> nvalue Then
MsgBox "N'oubliez pas de changer le numéro dans la colonne ABRÉVIATION!", vbExclamation, "IMPORTANT"
ActiveCell.Offset(-1, 0).Select
End If
Else
ActiveCell.Offset(-1, 0).Select
End If
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Voici mon fichier:
https://www.cjoint.com/?0DipTOn2Z5r
Pouvez vous m'aider sur celle là?!
Merci!
A voir également:
- Problème de protection lors de copie avec macro
- Copie cachée - Guide
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Super copie - Télécharger - Gestion de fichiers
- Copie écran samsung - Guide
- Copie disque dur - Guide
Voici mon code corrigé:
Private dlig As Long Private PL As Range Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim nvalue As String Dim NewVal As Variant Dim f As Worksheet Dim valueRange As Range Dim Cpt As Integer Dim nombre As Integer Dim i As Integer Application.ScreenUpdating = False nvalue = ActiveCell.Value If Not Intersect(Target, Range("c5:c" & [a1048576].End(xlUp).Row + 1)) Is Nothing Then If MsgBox("Voulez-vous mofifier le numéro de ce sondage?", _ vbYesNo + vbQuestion, "MODIFER") = vbYes Then NewVal = UCase(InputBox("Nouveau numéro de sondage?", "MODIFICATION DE NUMÉRO")) If NewVal = "" Then ActiveCell.Offset(-1, 0).Select Exit Sub Else ActiveCell = NewVal End If If InStr(1, nvalue, "C") = 1 Or InStr(1, nvalue, "M") = 1 Then Set valueRange = Sheets("CPTU").Columns(1) ElseIf InStr(1, nvalue, "F") = 1 Then Set valueRange = Sheets("FORAGE").Columns(1) ElseIf InStr(1, nvalue, "Z") = 1 Or InStr(1, nvalue, "FZ") = 1 Then Set valueRange = Sheets("Piézomètres").Columns(2) ElseIf InStr(1, nvalue, "I") = 1 Then Set valueRange = Sheets("Inclinomètres").Columns(2) Else Set valueRange = Nothing MsgBox "La valeur n'a pas été trouvé dans les autres feuilles! Mettre à jours les feuillets sur la page d'accueil!", vbCritical End If If Not valueRange Is Nothing Then nombre = ActiveWorkbook.Sheets.Count Application.ScreenUpdating = False For i = 1 To nombre Worksheets(i).Unprotect Next i valueRange.Replace nvalue, NewVal, lookat:=xlWhole, searchorder:=xlByColumns End If If NewVal <> nvalue Then MsgBox "N'oubliez pas de changer le numéro dans la colonne ABRÉVIATION!", vbExclamation, "IMPORTANT" ActiveCell.Offset(-1, 0).Select End If nombre = ActiveWorkbook.Sheets.Count Application.ScreenUpdating = False For i = 1 To nombre Worksheets(i).Protect Next i Else ActiveCell.Offset(-1, 0).Select End If End If Application.ScreenUpdating = True Application.EnableEvents = True End Sub