J'ai une macro avec un InputBox, elle marche bien lorsque je saisie une valeur à l'intérieure. Mais lorsque je veux annulé avec le bouton, il me renvoie la valeur faux dans la cellule sélectionnée.
J'ai essayé de lui dire si il y a une valeur pour NewVal alors exécute la macro sinon sort de la macro, mai sans succès!
Je voudrais que lorsque j'appui sur le bouton annulé de l'InputBox, qu'il quitte la macro.
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 String
Dim f As Worksheet
Dim valueRange As Range
Application.ScreenUpdating = False
For Each f In ActiveWorkbook.Worksheets
f.Unprotect
Next
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$(Application.InputBox("Nouveau numéro de sondage?", "MODIFICATION DE NUMÉRO", Type:=2))
If NewVal = "" Then
ActiveCell = NewVal
Else
ActiveCell.Offset(-1, 0).Select
Exit Sub
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
For Each f In ActiveWorkbook.Worksheets
f.Protect
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
J'ai essayé les 2 codes et dans les 2 cas lorsque je sélectionne le bouton annulé dans l'InputBox, il saute à ligne après le loop. C'est probablement le gars derrière le clavier le problème!
Voici ce que j'ai fait:
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 String
Dim f As Worksheet
Dim valueRange As Range
Dim Cpt As Integer
Application.ScreenUpdating = False
For Each f In ActiveWorkbook.Worksheets
f.Unprotect
Next
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
Cpt = 1
NewVal = UCase$(Application.InputBox("Nouveau numéro de sondage?", "MODIFICATION DE NUMÉRO", Type:=2))
Do While Len(NewVal) = 0
Cpt = Cpt + 1
If Cpt = 4 Then GoTo TropBetePourContinuer
ActiveCell.Offset(-1, 0).Select
Exit Sub
Loop
ActiveCell = NewVal
TropBetePourContinuer:
MsgBox "Veuillez arrêter l'informatique"
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
For Each f In ActiveWorkbook.Worksheets
f.Protect
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
C'est probablement le gars derrière le clavier le problème! Pas forcément. Quand on est dedans on ne voit pas tout...
Notamment le traitement d'erreur.
Le Goto doit renvoyer à une étiquette qui "clos" le code. Comme ceci :
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 String
Dim f As Worksheet
Dim valueRange As Range
Dim Cpt As Integer
Application.ScreenUpdating = False
For Each f In ActiveWorkbook.Worksheets
f.Unprotect
Next
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
Cpt = 1
NewVal = UCase$(Application.InputBox("Nouveau numéro de sondage?", "MODIFICATION DE NUMÉRO", Type:=2))
Do While Len(NewVal) = 0
Cpt = Cpt + 1
'*-*-*-*-*-*-*-*-*-*-*ICI LA SOURCE D'ERREUR POSSIBLE (GoTo renverra au traitement d'erreur en fin de code)
If Cpt = 4 Then GoTo TropBetePourContinuer
ActiveCell.Offset(-1, 0).Select
Exit Sub
Loop
ActiveCell = NewVal
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
For Each f In ActiveWorkbook.Worksheets
f.Protect
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
'ON QUITTE LA PROCEDURE pour ne pas entrer dans le traitement d'erreur
Exit Sub
'*-*-*-*-*-*-*-*-*-*-ICI LE TRAITEMENT D'ERREUR
TropBetePourContinuer:
MsgBox "Veuillez arrêter l'informatique"
End Sub
Ça ne marche pas comme je veux! Lorsque j'appui sur le bouton annulé dans l'InputBox il continue avec NewVal qui est égale à zéro ou vide et il me renvoie la valeur faux dans la cellule sélectionnée.
Alors que je veux que lorsque j'appui sur cette touche qu'il sorte de la macro.
Tu n'as pas utilisé mot pour moi le code donné par mon exemple.
Mea Culpa, je n'avais pas vu que tu utilisais une Application.InputBox de type 2 (chaîne de caractères). Ce type d'InputBox particulier renvoie "Faux" lorsqu'est cliqué le bouton Annuler.
Le test à faire alors pour sortir de la Sub est donc le suivant :
If NewVal = False Then Exit Sub
Ce qui te donne, à partir de ton code initial :
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 String
Dim f As Worksheet
Dim valueRange As Range
Application.ScreenUpdating = False
For Each f In ActiveWorkbook.Worksheets
f.Unprotect
Next
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$(Application.InputBox("Nouveau numéro de sondage?", "MODIFICATION DE NUMÉRO", Type:=2))
If NewVal = False 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
For Each f In ActiveWorkbook.Worksheets
f.Protect
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Notes : Si tu veux "donner" plusieurs essais à l'utilisateur, tu peux insérer la boucle Do While avec le compteur (Cpt). Dans le cas contraire, c'est ici inutile.
Application.EnableEvents = True
en fin de code est inutile puisque tu ne le places pas à False en début de code...
, je l'ai placé dans mon code parce que dans ma feuille, j'ai une autre macro qui s'effectue lors d'un changement dans la feuille. Elle se lance, donc à l'intérieure de cette macro lorsque je change la valeur d'une cellule et à la fin de l'exécution des 2 macros, aucune macro ne fonctionnent et en placent cette commande, tout est ok.
Peut-être pas la meilleur méthode, mais ça fonctionne!
Voici les macro en arrière de cette feuille:
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 String
Dim f As Worksheet
Dim valueRange As Range
Dim Cpt As Integer
Application.ScreenUpdating = False
For Each f In ActiveWorkbook.Worksheets
f.Unprotect
Next
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
Cpt = 1
NewVal = UCase$(Application.InputBox("Nouveau numéro de sondage?", "MODIFICATION DE NUMÉRO", Type:=2))
If NewVal = False 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
For Each f In ActiveWorkbook.Worksheets
f.Protect
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect
If Target.Column >= 3 And Target.Column <= 5 Then
'desactive les evenements excel: eviter appel recurcif a la suite du passage en majuscule
Application.EnableEvents = False
Target = UCase(Target)
End If
'active les evenements excel
Application.EnableEvents = True
If Target.Cells.Count > 1 Then Exit Sub
If Target.Row < 5 Or Target.Column <> 5 Then Exit Sub
If Target.Value = "" Then Cells(Target.Row, 1).ClearContents
If Range("A5") <> "" Then
dlig = Range("E5").End(xlDown).Row
Set PL = Range("A5:A" & dlig)
PL.Value = Range("a5").Value
End If
Dim T As Range, i&
Set T = [TableauCoord]
Application.EnableEvents = False
On Error Resume Next 'sécurité
If T.Rows.Count < 4 Then
Application.Undo 'annulation
Else
'---suppression des lignes vides---
For i = T.Rows.Count - 1 To 4 Step -1
If T(i, 1) = "" Then T(i, 1).EntireRow.Delete
Next
'---ajout de ligne---
If T(T.Rows.Count, 1) <> "" Then
Application.ScreenUpdating = False
T(T.Rows.Count, 1).EntireRow.Insert
T.Rows(T.Rows.Count - 1).FormulaR1C1 = T.Rows(T.Rows.Count).FormulaR1C1
T.Rows(T.Rows.Count) = ""
Application.ScreenUpdating = True
End If
End If
Dim Valeur As String
Dim Plage, Cellule As Range
' Ici spécifier la plage à couvrir !
Set Plage = Range("N5:N" & dlig)
For Each Cellule In Plage
Valeur = Mid(Cellule.Value, 2)
Valeur = UCase(Mid(Cellule.Value, 1, 1)) & Valeur
Cellule.Value = Valeur
Next Cellule
Application.EnableEvents = True
ActiveSheet.Protect
End Sub
Private Sub Worksheet_Activate()
Dim resultat As String
Const Dossier As String = "6.02.06.MT.02."
ActiveSheet.Unprotect
If Range("a5") = 0 Then
resultat = UCase(InputBox("Entrez le numéro du Bassin Versant!", "Bassin Versant"))
If resultat <> "" Then
dlig = Range("E5").End(xlDown).Row
Set PL = Range("A5:A" & dlig)
PL.Value = Dossier & resultat
End If
End If
ActiveSheet.Protect
Range("b5").Select
End Sub
Mais ça ne marche pas plus! Je n'y comprend rien!
J'ai essayé les 2 codes et dans les 2 cas lorsque je sélectionne le bouton annulé dans l'InputBox, il saute à ligne après le loop. C'est probablement le gars derrière le clavier le problème!
Voici ce que j'ai fait:
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 String Dim f As Worksheet Dim valueRange As Range Dim Cpt As Integer Application.ScreenUpdating = False For Each f In ActiveWorkbook.Worksheets f.Unprotect Next 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 Cpt = 1 NewVal = UCase$(Application.InputBox("Nouveau numéro de sondage?", "MODIFICATION DE NUMÉRO", Type:=2)) Do While Len(NewVal) = 0 Cpt = Cpt + 1 If Cpt = 4 Then GoTo TropBetePourContinuer ActiveCell.Offset(-1, 0).Select Exit Sub Loop ActiveCell = NewVal TropBetePourContinuer: MsgBox "Veuillez arrêter l'informatique" 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 For Each f In ActiveWorkbook.Worksheets f.Protect Next Application.ScreenUpdating = True Application.EnableEvents = True End SubPouvez-vous m'aider, merci!
Pas forcément. Quand on est dedans on ne voit pas tout...
Notamment le traitement d'erreur.
Le Goto doit renvoyer à une étiquette qui "clos" le code. Comme ceci :
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 String Dim f As Worksheet Dim valueRange As Range Dim Cpt As Integer Application.ScreenUpdating = False For Each f In ActiveWorkbook.Worksheets f.Unprotect Next 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 Cpt = 1 NewVal = UCase$(Application.InputBox("Nouveau numéro de sondage?", "MODIFICATION DE NUMÉRO", Type:=2)) Do While Len(NewVal) = 0 Cpt = Cpt + 1 '*-*-*-*-*-*-*-*-*-*-*ICI LA SOURCE D'ERREUR POSSIBLE (GoTo renverra au traitement d'erreur en fin de code) If Cpt = 4 Then GoTo TropBetePourContinuer ActiveCell.Offset(-1, 0).Select Exit Sub Loop ActiveCell = NewVal 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 For Each f In ActiveWorkbook.Worksheets f.Protect Next Application.ScreenUpdating = True Application.EnableEvents = True 'ON QUITTE LA PROCEDURE pour ne pas entrer dans le traitement d'erreur Exit Sub '*-*-*-*-*-*-*-*-*-*-ICI LE TRAITEMENT D'ERREUR TropBetePourContinuer: MsgBox "Veuillez arrêter l'informatique" End SubÇa ne marche pas comme je veux! Lorsque j'appui sur le bouton annulé dans l'InputBox il continue avec NewVal qui est égale à zéro ou vide et il me renvoie la valeur faux dans la cellule sélectionnée.
Alors que je veux que lorsque j'appui sur cette touche qu'il sorte de la macro.
Merci!
Tu n'as pas utilisé mot pour moi le code donné par mon exemple.
Mea Culpa, je n'avais pas vu que tu utilisais une Application.InputBox de type 2 (chaîne de caractères). Ce type d'InputBox particulier renvoie "Faux" lorsqu'est cliqué le bouton Annuler.
Le test à faire alors pour sortir de la Sub est donc le suivant :
Ce qui te donne, à partir de ton code initial :
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 String Dim f As Worksheet Dim valueRange As Range Application.ScreenUpdating = False For Each f In ActiveWorkbook.Worksheets f.Unprotect Next 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$(Application.InputBox("Nouveau numéro de sondage?", "MODIFICATION DE NUMÉRO", Type:=2)) If NewVal = False 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 For Each f In ActiveWorkbook.Worksheets f.Protect Next Application.ScreenUpdating = True Application.EnableEvents = True End SubNotes :
Si tu veux "donner" plusieurs essais à l'utilisateur, tu peux insérer la boucle Do While avec le compteur (Cpt). Dans le cas contraire, c'est ici inutile.
en fin de code est inutile puisque tu ne le places pas à False en début de code...
C'est exactement ça! Ça fonctionne super!
Pour le , je l'ai placé dans mon code parce que dans ma feuille, j'ai une autre macro qui s'effectue lors d'un changement dans la feuille. Elle se lance, donc à l'intérieure de cette macro lorsque je change la valeur d'une cellule et à la fin de l'exécution des 2 macros, aucune macro ne fonctionnent et en placent cette commande, tout est ok.
Peut-être pas la meilleur méthode, mais ça fonctionne!
Voici les macro en arrière de cette feuille:
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 String Dim f As Worksheet Dim valueRange As Range Dim Cpt As Integer Application.ScreenUpdating = False For Each f In ActiveWorkbook.Worksheets f.Unprotect Next 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 Cpt = 1 NewVal = UCase$(Application.InputBox("Nouveau numéro de sondage?", "MODIFICATION DE NUMÉRO", Type:=2)) If NewVal = False 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 For Each f In ActiveWorkbook.Worksheets f.Protect Next Application.ScreenUpdating = True Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) ActiveSheet.Unprotect If Target.Column >= 3 And Target.Column <= 5 Then 'desactive les evenements excel: eviter appel recurcif a la suite du passage en majuscule Application.EnableEvents = False Target = UCase(Target) End If 'active les evenements excel Application.EnableEvents = True If Target.Cells.Count > 1 Then Exit Sub If Target.Row < 5 Or Target.Column <> 5 Then Exit Sub If Target.Value = "" Then Cells(Target.Row, 1).ClearContents If Range("A5") <> "" Then dlig = Range("E5").End(xlDown).Row Set PL = Range("A5:A" & dlig) PL.Value = Range("a5").Value End If Dim T As Range, i& Set T = [TableauCoord] Application.EnableEvents = False On Error Resume Next 'sécurité If T.Rows.Count < 4 Then Application.Undo 'annulation Else '---suppression des lignes vides--- For i = T.Rows.Count - 1 To 4 Step -1 If T(i, 1) = "" Then T(i, 1).EntireRow.Delete Next '---ajout de ligne--- If T(T.Rows.Count, 1) <> "" Then Application.ScreenUpdating = False T(T.Rows.Count, 1).EntireRow.Insert T.Rows(T.Rows.Count - 1).FormulaR1C1 = T.Rows(T.Rows.Count).FormulaR1C1 T.Rows(T.Rows.Count) = "" Application.ScreenUpdating = True End If End If Dim Valeur As String Dim Plage, Cellule As Range ' Ici spécifier la plage à couvrir ! Set Plage = Range("N5:N" & dlig) For Each Cellule In Plage Valeur = Mid(Cellule.Value, 2) Valeur = UCase(Mid(Cellule.Value, 1, 1)) & Valeur Cellule.Value = Valeur Next Cellule Application.EnableEvents = True ActiveSheet.Protect End Sub Private Sub Worksheet_Activate() Dim resultat As String Const Dossier As String = "6.02.06.MT.02." ActiveSheet.Unprotect If Range("a5") = 0 Then resultat = UCase(InputBox("Entrez le numéro du Bassin Versant!", "Bassin Versant")) If resultat <> "" Then dlig = Range("E5").End(xlDown).Row Set PL = Range("A5:A" & dlig) PL.Value = Dossier & resultat End If End If ActiveSheet.Protect Range("b5").Select End SubEncore merci!