Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1456to1460
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Blattschutz von mehreren Excel-Dateien aufheben

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

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

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Blattschutz von mehreren Excel-Dateien aufheben
15.11.2015 15:31:37
Sepp
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

Anzeige
AW: Blattschutz von mehreren Excel-Dateien aufheben
15.11.2015 15:39:45
Nepumuk
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

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

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

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige