Das Archiv des Excel-Forums

allgemeingültig Blattschutz aufheben

Bild

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


Bild

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



 Bild

Excel-Beispiele zum Thema "allgemeingültig Blattschutz aufheben"

Kennwort für Blattschutz download Blattschutz aufheben download
Blattschutzdialog über VBA aufrufen download Blattschutz für eine Serie von Tabellen setzen und aufheben download
Blattschutz beim Speichern setzen download Blattschutz setzen und dennoch mit AutoFiltern download
Blattschutz aufheben, Daten eintragen, Blattschutz setzen download Blattschutz für VBA-Einträge ausschließen download
Blattschutz mit und ohne Passwort aufheben und setzen download Spaltenweiser Blattschutz in Abhängigkeit des Anwendernamens download
Blattschutz für alle Arbeitsblätter setzen oder aufheben download Bezüge auf Namen in anderen Mappen aufheben download