Passwortgeschützte Excel Dateien bearbeiten VBA Makro
Ich möchte Fußzeilen in alle Excel Dateien eines Ordners einfügen. Das klappt alles soweit, leider sind alle Dateien passwortgeschützt. Das Makro sollte eigentlich funktionieren, macht es aber nicht...
Danke für eure Hilfe =D
Danke für eure Hilfe =D
Sub makro_filename()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean
MyPath = "irgendeinpfad"
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "Keine Dateien gefunden"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open((MyPath & MyFiles(Fnum)), , , , Password:="password")
On Error GoTo 0
If Not mybook Is Nothing Then
'Change cell value(s) in all worksheets in mybook
On Error Resume Next
For Each sh In mybook.Worksheets
If sh.ProtectContents = False Then
With sh
.PageSetup.LeftFooter = "Form-Nr. " & mybook.Name
.Range("A7:I11").Interior.Color = RGB(224, 224, 224)
' change footer in every worksheet
End With
Else
ErrorYes = True
End If
Next sh
If Err.Number > 0 Then
ErrorYes = True
Err.Clear
'Close mybook without saving
mybook.Close savechanges:=False
Else
'Save and close mybook
mybook.Close savechanges:=True
End If
On Error GoTo 0
Else
'Not possible to open the workbook
ErrorYes = True
End If
Next Fnum
End If
If ErrorYes = True Then
MsgBox "There are problems in one or more files, possible problem:" _
& vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Please also mark the comments that contributed to the solution of the article
Content-Key: 368255
Url: https://administrator.de/contentid/368255
Printed on: April 26, 2024 at 08:04 o'clock
2 Comments
Latest comment