VBA - Placement code dévérouillage/verrouillage
Bonjour à tous
J'ai une petite question, j'ai le code ci-dessous :
Sub InjectionGlobal()
Dim Chemin As String, Fichier As String
Dim Ws As Worksheet
Dim NbLg As Long
Application.ScreenUpdating = False
Set Ws = Sheets("Injection")
Chemin = ThisWorkbook.Path & Application.PathSeparator
Fichier = "Injection_Globale.xlsx"
If Dir(Chemin & Fichier) = "" Then
Ws.Copy
ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Chemin & Fichier, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
Else
NbLg = Ws.Range("A" & Rows.Count).End(xlUp).Row
If NbLg > 1 Then
With Workbooks.Open(Chemin & Fichier)
Ws.Range("A2:F" & NbLg).Copy .Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Close savechanges:=True
End With
End If
End If
MsgBox "Copie terminé"
End Sub
Et je doit insérer dans l'ordre le code qui dévérouille et revérouille après exécution de la macro.
.Unprotect Password:="200997"
.Protect Password:="200997"
Je ne sais pas a quel endroit les insérer, auriez-vous une idée?
En vous en remerciant bien par avance.
Bien cordialement.
Bonjour,
Ta question est ... pour le moins ... surprenante ...
As-tu fait un test ...???
Bonjour,
Oui j'ai testé, en fait cette macro pour s'exécuter, doit connaitre le mot de passe de l'onglet car celui-ci est verrouillé.
Si je ne mets pas de protection de l'onglet par MDP, la macro fonctionne parfaitement, si je mets la protection avec le code 200997 j'ai l'erreur suivante :
En fait la macro, récupère des données d'autres onglets et doit les coller dans l'onglet verrouillé.
Le problème c'est que je ne sais pas ou positionner les deux codes déverrouillage et verrouillage.
Lorsque je clique sur débogage j'obtiens ceci ( Range("A2:F" & Rows.Count).ClearContents) en surlignage jaune :
Sub Synthese()
Dim NbLg As Long, Ligne As Long
Dim WsL As Worksheet
Dim Cel As Range, Kase As Range
Dim LesFeuilles
Dim I As Integer, Colonne As Integer
Application.ScreenUpdating = False
Range("A2:F" & Rows.Count).ClearContents
Ligne = 1
Set WsL = Sheets("Liste complète des PERS DIR")
LesFeuilles = Array("Astreintes", "Prime encadrement de nuit", "Indem horaire travail DJF")
For I = 0 To UBound(LesFeuilles)
With Sheets(LesFeuilles(I))
.Unprotect Password:="200997"
NbLg = .Range("B" & Rows.Count).End(xlUp).Row
If I = 2 Then Colonne = 8 Else Colonne = 12
.Range(.Cells(17, Colonne), .Cells(NbLg, Colonne)).AutoFilter field:=1, Criteria1:=">0"
.Range("L17:L" & NbLg).AutoFilter field:=1, Criteria1:=">0"
If Application.Subtotal(103, .Range("B18:B" & NbLg)) > 0 Then
For Each Cel In .Range("B18:B" & NbLg).SpecialCells(xlCellTypeVisible)
Set Kase = WsL.Columns("A").Find(what:=Replace(Replace(Cel, " ", ""), "|", ""), LookIn:=xlValues, lookat:=xlPart)
If Not Kase Is Nothing Then
Ligne = Ligne + 1
Range("A" & Ligne) = Kase
Range("B" & Ligne) = Kase.Offset(0, 1) & "," & Kase.Offset(0, 2)
Range("C" & Ligne) = .Range("M2")
Range("D" & Ligne) = .Range("N3")
Range("E" & Ligne) = CDate(.Range("E12"))
Range("F" & Ligne) = .Cells(Cel.Row, Colonne) * 100 'Cel.Offset(0, 10)
Else
MsgBox "Code " & Cel & " introuvable"
End If
Next Cel
End If
.AutoFilterMode = False
.Protect Password:="200997"
End With
Next I
InjectionGlobal
End Sub
Sub InjectionGlobal()
Dim Chemin As String, Fichier As String
Dim Ws As Worksheet
Dim NbLg As Long
Application.ScreenUpdating = False
Set Ws = Sheets("Injection")
Chemin = ThisWorkbook.Path & Application.PathSeparator
Fichier = "Injection_Globale.xlsx"
If Dir(Chemin & Fichier) = "" Then
Ws.Copy
ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Chemin & Fichier, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
Else
NbLg = Ws.Range("A" & Rows.Count).End(xlUp).Row
If NbLg > 1 Then
With Workbooks.Open(Chemin & Fichier)
Ws.Range("A2:F" & NbLg).Copy .Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Close savechanges:=True
End With
End If
End If
MsgBox "Copie terminé"
End Sub
Bien cordialement.
Re,
A tester ...
Sub InjectionGlobal()
Dim Chemin As String, Fichier As String
Dim Ws As Worksheet
Dim NbLg As Long
Application.ScreenUpdating = False
Set Ws = Sheets("Injection")
Chemin = ThisWorkbook.Path & Application.PathSeparator
Fichier = "Injection_Globale.xlsx"
If Dir(Chemin & Fichier) = "" Then
Ws.Copy
ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Chemin & Fichier, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
Else
NbLg = Ws.Range("A" & Rows.Count).End(xlUp).Row
If NbLg > 1 Then
With Workbooks.Open(Chemin & Fichier)
.Unprotect Password:="200997"
Ws.Range("A2:F" & NbLg).Copy .Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Protect Password:="200997"
.Close savechanges:=True
End With
End If
End If
MsgBox "Copie terminé"
End Sub
Re
Merci pour ton aide.
Je viens de tester, il me retourne toujours l'erreur, et quand je fais débogage j'ai cela :
La macro InjectionGlobal est la suivante :
Option Explicit
Sub Synthese()
Dim NbLg As Long, Ligne As Long
Dim WsL As Worksheet
Dim Cel As Range, Kase As Range
Dim LesFeuilles
Dim I As Integer, Colonne As Integer
Application.ScreenUpdating = False
Range("A2:F" & Rows.Count).ClearContents
Ligne = 1
Set WsL = Sheets("Liste complète des PERS DIR")
LesFeuilles = Array("Astreintes", "Prime encadrement de nuit", "Indem horaire travail DJF")
For I = 0 To UBound(LesFeuilles)
With Sheets(LesFeuilles(I))
.Unprotect Password:="200997"
NbLg = .Range("B" & Rows.Count).End(xlUp).Row
If I = 2 Then Colonne = 8 Else Colonne = 12
.Range(.Cells(17, Colonne), .Cells(NbLg, Colonne)).AutoFilter field:=1, Criteria1:=">0"
.Range("L17:L" & NbLg).AutoFilter field:=1, Criteria1:=">0"
If Application.Subtotal(103, .Range("B18:B" & NbLg)) > 0 Then
For Each Cel In .Range("B18:B" & NbLg).SpecialCells(xlCellTypeVisible)
Set Kase = WsL.Columns("A").Find(what:=Replace(Replace(Cel, " ", ""), "|", ""), LookIn:=xlValues, lookat:=xlPart)
If Not Kase Is Nothing Then
Ligne = Ligne + 1
Range("A" & Ligne) = Kase
Range("B" & Ligne) = Kase.Offset(0, 1) & "," & Kase.Offset(0, 2)
Range("C" & Ligne) = .Range("M2")
Range("D" & Ligne) = .Range("N3")
Range("E" & Ligne) = CDate(.Range("E12"))
Range("F" & Ligne) = .Cells(Cel.Row, Colonne) * 100 'Cel.Offset(0, 10)
Else
MsgBox "Code " & Cel & " introuvable"
End If
Next Cel
End If
.AutoFilterMode = False
.Protect Password:="200997"
End With
Next I
InjectionGlobal
End Sub
Sub InjectionGlobal()
Dim Chemin As String, Fichier As String
Dim Ws As Worksheet
Dim NbLg As Long
Application.ScreenUpdating = False
Set Ws = Sheets("Injection")
Chemin = ThisWorkbook.Path & Application.PathSeparator
Fichier = "Injection_Globale.xlsx"
If Dir(Chemin & Fichier) = "" Then
Ws.Copy
ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Chemin & Fichier, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
Else
NbLg = Ws.Range("A" & Rows.Count).End(xlUp).Row
If NbLg > 1 Then
With Workbooks.Open(Chemin & Fichier)
.Unprotect Password:="200997"
Ws.Range("A2:F" & NbLg).Copy .Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Protect Password:="200997"
.Close savechanges:=True
End With
End If
End If
MsgBox "Copie terminé"
End Sub
Cordialement.
Re,
Désolé ... mais je n'arrive pas du tout à suivre ta pensée ...
Dans un premier temps, tu veux insérer dans une macro une instruction pour déprotéger et reprotéger un fichier ...
Non seulement tu ne me dis pas si la modification a été utile ou pas ...
Mais maintenant tu me parles d'un bug dans une autre macro
Perso, je suis obligé de passer la main ...
Bon Courage pour la suite ...
Bonsoir James,
Tout d'abord merci pour ton aide et désolé si je n'arrive pas a t'expliquer plus clairement mon problème.
Bonne soirée à toi.
A plus tard sur le forum.
Hello,
Ce sera peut être mieux avec un fichier exemple :
https://forum.excel-pratique.com/post325955.html#p325955
Cordialement.