MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Excel
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 12.09.2019, 12:09   #1
h.foerster@le-co.de
Neuer Benutzer
Neuer Benutzer
Beeindruckt Excel2010 - VBA Code mehrere Dateien mit einem Passwort schützen

Hallo liebe Community,

ich muß einen Ordner mit 813 .xlsx Dateien mit dem gleichen Passwort versehen. Leider habe ich nur noch einen VBA code für die alten Excel Programme und der funktioniert einfach nicht. Ich finde den Fehler aber nicht.

Hat jemand eine Idee und kann mir den Code korrigieren. Nur das Umschreiben auf .xlsx klappt nicht.

Hier der Code:

Const strVerzeichnis As String = "Y:AtrNr 2561Test"
Sub Ordnerschutz2002()
Dim PwdAlt, PwdNeu
Dim strDatei As String, strFehler As String
Dim objMappe As Workbook

On Error GoTo ErrorHandler

PwdAlt = Application.InputBox("Geben Sie das bisher benutzte Kennwort ein:")
If PwdAlt = False Then Exit Sub
PwdNeu = Application.InputBox("Geben Sie ein neues Kennwort ein:")
If PwdNeu = False Then Exit Sub

Application.ScreenUpdating = False
strDatei = Dir(strVerzeichnis & "*.xls")
Do While strDatei <> ""
Set objMappe = Application.Workbooks.Open _
(Filename:=strVerzeichnis & strDatei, _
Password:=PwdAlt)
With objMappe
.Password = PwdNeu
.Close SaveChanges:=True
End With
Set objMappe = Nothing
Weiter:
strDatei = Dir
Loop

'Ende:
If strFehler = "" Then
MsgBox "Alle Dateien im Ordner" & vbCr & _
strVerzeichnis & vbCr & "bearbeitet ..."
Application.ScreenUpdating = True
Exit Sub
Else
MsgBox strFehler, vbOKOnly, "Es sind Fehler bei folgenden Arbeitsmappen aufgetreten:"
End If
Application.ScreenUpdating = True
Exit Sub

ErrorHandler:
If strFehler = "" Then
strFehler = strDatei
Cells(1, 1).Value = "Es traten Fehler bei folgenden Mappen auf:"
Cells(2, 1).Value = "Name der Mappe"
Cells(2, 2).Value = "Fehlernummer"
Cells(2, 3).Value = "Fehlerbeschreibung"
Range("A2:C2").Columns.AutoFit
i = 3
Cells(i, 1).Value = strDatei
Cells(i, 2).Value = Err.Number
Cells(i, 3).Value = Err.Description
Else
strFehler = strFehler & ", " & strDatei
i = i + 1
Cells(i, 1).Value = strDatei
Cells(i, 2).Value = Err.Number
Cells(i, 3).Value = Err.Description

End If
Resume Weiter
' Resume Ende
End Sub


Vielen Dank!
h.foerster@le-co.de ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 12.09.2019, 12:52   #2
Der Steuerfuzzi
MOF Profi
MOF Profi
Standard

Hallo,

was für ein Fehler tritt denn auf? In welcher Zeile?

__________________

Gruß
Michael
Der Steuerfuzzi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 12.09.2019, 18:32   #3
ReginaR
MOF Profi
MOF Profi
Standard

Hi, hier wird nur nach der Endung "xls" gesucht:

strDatei = Dir(strVerzeichnis & "*.xls")

__________________

Gruß
Regina
ReginaR ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.09.2019, 06:59   #4
Der Steuerfuzzi
MOF Profi
MOF Profi
Standard

@Regina:

Zitat: von h.foerster@le-co.de Beitrag anzeigen

Nur das Umschreiben auf .xlsx klappt nicht.

Ich vermute mal, das hat er/sie schon versucht ...

__________________

Gruß
Michael
Der Steuerfuzzi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 19:35 Uhr.



Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.