Blattschutz über alle Excel-Dateien eines Ordners

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Sub AlleMappenInVerz() Dim strFile As String Const strVerz As String = "C:\Test\" ' anpassen On Error GoTo XEnd strFile = Dir(strVerz & "*.xls*") With Application .AskToUpdateLinks = False .EnableEvents = False .DisplayAlerts = False While strFile "" If UCase$(strFile) UCase$(ThisWorkbook) Then Workbooks.Open strVerz & strFile, False, False, , , , True ' BlattschutzAufheben ' oder BlattschutzSetzen ActiveWorkbook.Close True End If strFile = Dir Wend XEnd: On Error GoTo 0 .AskToUpdateLinks = True .EnableEvents = True .DisplayAlerts = True End With End Sub Sub BlattschutzAufheben() Dim wks As Worksheet For Each wks In ActiveWorkbook.Worksheets wks.Unprotect "geh_heim" Next wks End Sub Sub BlattschutzSetzen() Dim wks As Worksheet For Each wks In ActiveWorkbook.Worksheets wks.Protect "geh_heim" Next wks End Sub

Hallo Bernd,
probiere mal.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub schutzAn()
  protectAllSheets "E:\Forum", "DeinPasswort", True
End Sub


Sub schutzAus()
  protectAllSheets "E:\Forum", "DeinPasswort", False
End Sub


Sub protectAllSheets(Directory As String, Password As String, Protection As Boolean)
  Dim objWB As Workbook, objSH As Worksheet
  Dim strFile As String, strDir As String
  Dim lngCalc As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  strDir = IIf(Right(Directory, 1) = "\", Directory, Directory & "\")
  
  strFile = Dir(strDir & "*.xls*", vbNormal)
  
  Do While strFile <> ""
    If strDir & strFile <> ThisWorkbook.FullName Then
      Set objWB = Workbooks.Open(strDir & strFile, UpdateLinks:=False)
      For Each objSH In objWB.Worksheets
        If Protection Then
          objSH.Protect Password
        Else
          objSH.Unprotect Password
        End If
      Next
      objWB.Close True
    End If
    strFile = Dir
  Loop
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'protectAllSheets'" & 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 Modul - Modul1"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
  End With
  
  Set objWB = Nothing
  Set objSH = Nothing
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

Blattschutz über alle Excel-Dateien eines Ordners

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Blattschutz über alle Excel-Dateien eines Ordners

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread