Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

allgemeingültig Blattschutz aufheben

Betrifft: allgemeingültig Blattschutz aufheben von: Andreas
Geschrieben am: 23.11.2007 08:26:13

Hallo,

ich hab bei meiner Prozedur zum Ändern (siehe unten) ein Problem. Es gibt Dateien, wo ich Änderungen in den Verknüpfungen vornehmen muss, wo ein Blattschutz drüber liegt. Wie kann ich in die Prozedur einbauen, dass dieser Blattschutz entfernt / aufgehoben wird auch wenn ich bis jetzt noch gar nicht eingebaut habe, wie viele Tabellenblätter die unterschiedlichen Dateien haben, wo Veränderungen vorgenommen werden?
Es ist so, dass ich eine Vielzahl Dateien nach Verknüpfungen untersuchen muss und wenn ganz bestimmte Verknüpfungen vorkommen, müssen die geändert werden. Zum jetzigen Zeitpunkt ist das noch so, dass es aber einige Dateien (eben wahrscheinlich wegen des Blattschutzes) gibt, bei denen das Ändern nicht funktioniert. Viele Dinge sind ja in der Prozedur schon eingebaut, wie „Nicht aktualisieren“ von Verknüpfungen beim Öffnen, „Makros deaktivieren“, Öffnen obwohl Schreibschutz, … Es fehlt aber noch das Entfernen des Blattschutzes. Da müsste man doch die gesamten Blätter erst durchgehen, oder?
Und dann ist mir noch aufgefallen, dass ein paar wenige Dateien gar nicht geschlossen werden. Wieso kann ich mir nicht erklären. Das muss doch irgendein kleiner Fehler oder eine ungünstige Anweisung in der Prozedur sein, oder?

Kann mir bitte jemand mit dem Stück VBA helfen, um das allgemeingültig in die Prozedur einzubauen?

Gruss
Andreas

Hier noch die Prozedur:

Option Explicit
Dim z As Long

' Rekursive Prozedur

Public Sub xDirFile(xpath As String)
    Dim xa As Long
    Dim xDir As String
    ReDim xt(0) As String
    Dim xi As Long
    Dim xAc As String
    Dim wb As Workbook
    Dim aLinks
    Dim I As Integer
    Dim newlink As String
    
    ' Zulassen von allen Formen von Dateien
    ' schreibgeschützte, versteckte, Systemdateien, Verzeichnisse, Ordner, ...
    xDir = Dir(xpath & "\*.*", vbNormal Or vbReadOnly Or vbHidden _
        Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)
    
    xa = 0
    
    If Len(xDir) > 0 Then
        xt(0) = xDir
    End If
    
    Do While Len(xDir) > 0
        xDir = Dir
        If Len(xDir) > 0 And Not xDir = "." And Not xDir = ".." Then
            
            xa& = xa& + 1
            ReDim Preserve xt(xa)
            xt(xa) = xDir
        End If
    Loop
    
    On Error GoTo Schleife
    
    For xi& = 0 To xa&
        If Len(xt(xi)) = 0 Then
            Exit For
        ElseIf Not xt(xi) = "." And Not xt(xi) = ".." Then
            If Len(Dir$(xpath$ & "\" & xt$(xi&), vbNormal Or vbReadOnly Or vbHidden _
                Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)) > 0 Then
                
                If Not (GetAttr(xpath & "\" & xt(xi)) And vbDirectory) = vbDirectory Then
                    
                  'Aufgaben, die zu erledigen sind
                
                  'wenn Exceldatei
                  If UCase(Right(xt(xi), 3)) = "XLS" Then
                    'Debug.Print xpath & "\" & xt(xi)
  
                    ' die "0" bedeutet, dass die Frage nach der Aktualisierung
                    ' von Verlinkungen verneint wird
                    Set wb = Workbooks.Open(xpath & "\" & xt(xi), 0)
                    aLinks = wb.LinkSources(xlExcelLinks)
                    If Not IsEmpty(aLinks) Then
                      ' Zählvariable -> kann weggelassen werden
                      z = z + 1
                      
                      ' diese Funktion steht im Modul "Referenzen"
                      NEUVERLINKEN aLinks, wb
                      
                    End If
                    
                    ' Schreiben der Links in das Direktfenster
                    'Debug.Print xpath & "\" & xt(xi)
                    
                    wb.Close savechanges:=False
                    Set wb = Nothing
                  End If
                  
                Else
                    Call xDirFile(xpath & "\" & xt(xi))
                End If
            End If
        End If

Schleife:
    Next xi&
    On Error GoTo 0
End Sub


  

Betrifft: AW: allgemeingültig Blattschutz aufheben von: fcs
Geschrieben am: 23.11.2007 21:14:56

Hallo Andreas,


ungetested müssten die folgenden Anpassungen funktionieren. Nach dem Öffen der Dateien wird der Blattschutz aller Blätter in einer Array-Variablen gemerkt, dann der Blattschutz aufgehoben. Nach dem Aktualisieren der Verknüpfungen wird der Blattschutz wieder hergestellt.

Dateien bleiben bei deiner Version geöffnet, wenn nach dem Öffnen der Datei in der Schleife ein Fehler auftritt und zur Adresse "Schleife" gesprungen wird ohne die Datei zu schliessen. Ich habe eine entsprechende Meldung eingebaut, nach der die Datei geschlossen wird.

Gruß
Franz

Public Sub xDirFile(xpath As String)
    Dim xa As Long
    Dim xDir As String
    ReDim xt(0) As String
    Dim xi As Long
    Dim xAc As String
    Dim wb As Workbook
    Dim aLinks
    Dim I As Integer
    Dim newlink As String
    Dim wksSchutz() As Boolean, wks As Worksheet, iJ As Integer
    
    ' Zulassen von allen Formen von Dateien
    ' schreibgeschützte, versteckte, Systemdateien, Verzeichnisse, Ordner, ...
    xDir = Dir(xpath & "\*.*", vbNormal Or vbReadOnly Or vbHidden _
        Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)
    
    xa = 0
    
    If Len(xDir) > 0 Then
        xt(0) = xDir
    End If
    
    Do While Len(xDir) > 0
        xDir = Dir
        If Len(xDir) > 0 And Not xDir = "." And Not xDir = ".." Then
            
            xa& = xa& + 1
            ReDim Preserve xt(xa)
            xt(xa) = xDir
        End If
    Loop
    
    On Error GoTo Schleife
    
    For xi& = 0 To xa&
        If Len(xt(xi)) = 0 Then
            Exit For
        ElseIf Not xt(xi) = "." And Not xt(xi) = ".." Then
            If Len(Dir$(xpath$ & "\" & xt$(xi&), vbNormal Or vbReadOnly Or vbHidden _
                Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)) > 0 Then
                
                If Not (GetAttr(xpath & "\" & xt(xi)) And vbDirectory) = vbDirectory Then
                    
                  'Aufgaben, die zu erledigen sind
                
                  'wenn Exceldatei
                  If UCase(Right(xt(xi), 3)) = "XLS" Then
                    'Debug.Print xpath & "\" & xt(xi)
  
                    ' die "0" bedeutet, dass die Frage nach der Aktualisierung
                    ' von Verlinkungen verneint wird
                    Set wb = Workbooks.Open(xpath & "\" & xt(xi), 0)
                    
                    'Blattshutzmerken und aufheben
                    ReDim wksSchutz(1 To wb.Worksheets.Count)
                    For iJ = 1 To wb.Worksheets.Count
                      Set wks = wb.Worksheets(iJ)
                      wksSchutz(iJ) = wks.ProtectContents
                      If wks.ProtectContents = True Then
                        wks.Unprotect
                      End If
                    Next
                    
                    aLinks = wb.LinkSources(xlExcelLinks)
                    
                    If Not IsEmpty(aLinks) Then
                      ' Zählvariable -> kann weggelassen werden
                      z = z + 1
                      
                      ' diese Funktion steht im Modul "Referenzen"
                      NEUVERLINKEN aLinks, wb
                      
                    End If
                    
                    ' Schreiben der Links in das Direktfenster
                    'Debug.Print xpath & "\" & xt(xi)
                    'Blattshutz wieder setzen
                    For iJ = 1 To wb.Worksheets.Count
                      Set wks = wb.Worksheets(iJ)
                      If wksSchutz(iJ) = True Then
                        wks.Protect
                        wks.Protect contents:=True
                      End If
                    Next
                    wb.Save '???? soll das geänderte Workbook nicht gespeichert werden?
                    
                    wb.Close savechanges:=False
                    Set wb = Nothing
                    Set wks = Nothing
                    ReDim wksshutz(1 To 1)
                  End If
                  
                Else
                    Call xDirFile(xpath & "\" & xt(xi))
                End If
            End If
        End If

Schleife:
      'Datei nach Fehler schließen
      If Not wb Is Nothing Then
        MsgBox "Bei Datei " & wb.FullName & " ist ein Fehler aufgetreten" & vbLf & _
          "Datei wird ohne speichern geschlossen!!"
        wb.Close savechanges:=False
      End If
      
    Next xi&
    On Error GoTo 0
End Sub




 

Beiträge aus den Excel-Beispielen zum Thema "allgemeingültig Blattschutz aufheben"