Blattschutz von mehreren Excel-Dateien aufheben

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Blattschutz von mehreren Excel-Dateien aufheben
von: parza
Geschrieben am: 15.11.2015 15:23:45

Hallo Fachleute,
ich habe in einem Verzeichnis ca. 100 xls-Dateien mit mehreren Blättern, die alle mit einem Blattschutz, aber ohne Passwort versehen sind. Ist es möglich mit einem Makro, mit einem Klick bei allen Dateien den Blattschutz aufzuheben und ggf. anschließend auch wieder zu schützen?
Da ich absoluter vba-Laie bin, habe ich zwar intensiv gegoogelt, aber mein selbstgestrickter Versuch funktioniert wie zu erwarten nicht.
Ich hoffe, ihr könnt mir helfen.
Danke, Theo
Mein Versuch sieht so aus:

Sub FindFiles()
    Dim colAllFiles As Collection
    Dim fs As Filesearch
    Dim i As Integer
    
    Set fs = NewFilesearch
    With fs
        'es werden alle Ordner und Unterordner durchgesucht
        .LookIn = "e:\"
        .Filename = "*.xls"
        If .Execute > 0 Then
iCount = .FoundFiles.Count
      For iCounter = 1 To iCount
        Workbooks.Open Filename:=.FoundFiles(iCounter)
        For Each wks In ActiveWorkbook.Worksheets
            wks.Unprotect
            wks.Protect Password:="xxx"
        Next wks
        ActiveWorkbook.Close True
      Next iCounter
   
    End
        End If
    
End With
End Sub

Bild

Betrifft: AW: Blattschutz von mehreren Excel-Dateien aufheben
von: Sepp
Geschrieben am: 15.11.2015 15:31:37
Hallo Parza,
ungetestet!

' **********************************************************************
' Modul: Modul4 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub schutzAus()
Dim objWB As Workbook, objSh As Worksheet
Dim strFile As String, strPath As String

On Error GoTo ErrorHandler

Static CalculationMode As Long

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .AskToUpdateLinks = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  .DisplayAlerts = False
End With

strPath = "E:\Forum" 'Verzeichnis - Anpassen!

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

strFile = Dir(strPath & "*.xls", vbNormal)

Do While strFile <> ""
  Set objWB = Workbooks.Open(strPath & strFile)
  For Each objSh In objWB.Worksheets
    objSh.Unprotect
  Next
  objWB.Close True
  strFile = Dir
Loop

ErrorHandler:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'schutzAus'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - schutzAus"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalculationMode
  .DisplayAlerts = True
  .StatusBar = False
End With

Set objWB = Nothing
Set objSh = Nothing
End Sub

Sub schutzEin()
Dim objWB As Workbook, objSh As Worksheet
Dim strFile As String, strPath As String

On Error GoTo ErrorHandler

Static CalculationMode As Long

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .AskToUpdateLinks = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  .DisplayAlerts = False
End With

strPath = "E:\Forum" 'Verzeichnis - Anpassen!

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

strFile = Dir(strPath & "*.xls", vbNormal)

Do While strFile <> ""
  Set objWB = Workbooks.Open(strPath & strFile)
  For Each objSh In objWB.Worksheets
    objSh.Protect
  Next
  objWB.Close True
  strFile = Dir
Loop

ErrorHandler:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'schutzEin'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - schutzEin"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalculationMode
  .DisplayAlerts = True
  .StatusBar = False
End With

Set objWB = Nothing
Set objSh = Nothing
End Sub

Gruß Sepp


Bild

Betrifft: AW: Blattschutz von mehreren Excel-Dateien aufheben
von: Nepumuk
Geschrieben am: 15.11.2015 15:39:45
Hallo,
teste mal:

Option Explicit

Public Sub ResetProtection()
    
    Const FILE_PATH As String = "E:\"
    
    Dim strFileName As String
    Dim objWorkbook As Workbook
    Dim objWorksheet As Worksheet
    
    strFileName = Dir$(FILE_PATH & "*.xls*")
    
    Do Until strFileName = vbNullString
        
        Set objWorkbook = Workbooks.Open(Filename:=FILE_PATH & strFileName, UpdateLinks:=0)
        
        For Each objWorksheet In objWorkbook.Worksheets
            
            Call objWorksheet.Unprotect
            Call objWorksheet.Protect(Password:="xxx")
            
        Next
        
        Call objWorkbook.Close(SaveChanges:=True)
        Set objWorkbook = Nothing
        
        strFileName = Dir$
        
    Loop
End Sub

Gruß
Nepumuk

Bild

Betrifft: Blattschutz von mehreren Excel-Dateien aufheben
von: parza
Geschrieben am: 15.11.2015 16:22:43
Herzlichen Dank,
da gleich der erste Vorschlag gepasst hat, werde ich den zweiten LÖsungsvorschlag nächste ausprobieren.
Theo

Bild

Betrifft: AW: Blattschutz von mehreren Excel-Dateien aufheben
von: parza
Geschrieben am: 15.11.2015 16:24:07
Herzlichen Dank,
da gleich der erste Vorschlag von Sepp gepasst hat, werde ich deinen Lösungsvorschlag nächste Woche ausprobieren.
Theo

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Blattschutz von mehreren Excel-Dateien aufheben"