VBA - Placement code dévérouillage/verrouillage

Le 06/12/2014 à 11:49

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.

Le 06/12/2014 à 12:17

Bonjour,

Ta question est ... pour le moins ... surprenante ...

As-tu fait un test ...???

Le 06/12/2014 à 12:44

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.

Le 06/12/2014 à 13:22

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
Le 06/12/2014 à 14:11

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.

Le 06/12/2014 à 17:54

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 ...

Le 06/12/2014 à 19:47

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.

Le 06/12/2014 à 20:42

Hello,

Ce sera peut être mieux avec un fichier exemple :

https://forum.excel-pratique.com/post325955.html#p325955

Cordialement.

Rechercher des sujets similaires à "vba placement code deverouillage verrouillage"