XLK-Erstellen nachträglich

Hi Excelfriends,
Diese Frage habe ich auch schon in Officeloesung gestellt, da haben auch viele Leute reingesehen, aber leider war bisher kein Lösungsvorschlag dabei. Daher hier nochmal die Frage, weil ich sonst ein sehr langes und ermüdendes Szenario vor mir habe:
ich habe hier in diversen Verzeichnissen einige hundert xls-Dateien "geerbt", bei denen die Verursacher die Option "Sicherungskopie erstellen" nicht aktiviert haben. Diese jetzt alle manuell einzeln zu öffnen und unter einem anderen Namen zu speichern und dabei diese Option zu setzen, wäre eine Heidenarbeit.
Gibt es vielleicht unter VBA die Möglichkeit, alle xls-Dateien eines Verzeichnisses nachträglich mit dieser Option auszurüsten, so dass nach und nach bei jeder neuen Bearbeitung die entsprechenden xlk-Files angelegt werden?
Denkbar wäre auch eine Lösung in der Art:
öffne die erste xls-Datei im manuell ausgewählten Verzeichnis
speichern unter [Dateinamen].xls vergeben
Option Sicherungskopie erstellen setzen
speichern durchführen (Überschreiben bejahen)
Nächste Datei holen
wenn keine xls-mehr im Verzeichnis ist, ende des Makros
Ich habe selbst kaum VBA-Kenntnisse und habe daher mal mit dem Makrorekorder aufgezeichnet, was passieren soll.
Hier also gezielt eine einzelne Datei geändert, allerdings ohne den Dateinamen zu verändern:
'


Sub xlkeinschalten()
' Dieser Excel-Makro öffnet die angegebene Datei
' setzt mit -datei-speichern unter-extras-sicherheitskopie erstellen die option  _
sicherheitskopie
'speichert die datei
'und schliesst die angegebene Datei
Workbooks.Open Filename:="D:\workarea\Mappe1.xls"
ActiveWorkbook.SaveAs Filename:="D:\workarea\Mappe1.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=True
ActiveWorkbook.Close
End 

Sub
Was ich jetzt bräuchte wäre einfach der Loop, dass alle Dateien im gerade aktuellen Verzeichnis  _
der Reihe nach so behandelt werden, bis die letzte Datei verarbeitet ist.
Also:
Ich gehe in das erste Verzeichnis (wähle ich manuell aus)
Wähle die erste Datei aus
Wähle Makro-xlkeinschalten aus - ausführen
und dann soll über alle xls-Dateien des aktuellen verzeichnisses diese Option eingeschaltet  _
werden. Es ist sichergestellt, dass keine passwortgeschützten Dateien vorhanden sind und es sind reinrassig nur xls-Dateien in diesem Verzeichnis. Vielleicht kann mir da jemand den Code für den Loop dazuschreiben?
Danke schön & schönes Wochenende
Peter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub tt() Dim sPfad As String, sDatei As String With Application.FileDialog(4) .AllowMultiSelect = False .InitialFileName = "c:\test\" .Title = "Bitte Pfad wählen" .InitialView = 1 If .Show = -1 Then sPfad = .SelectedItems(1) End If End With If sPfad "" Then sPfad = sPfad & "\" sDatei = Dir(sPfad & "*.xls") On Error GoTo ErrHandler With Application .DisplayAlerts = False .ScreenUpdating = False .EnableEvents = False End With Do While sDatei "" Workbooks.Open sPfad & sDatei With ActiveWorkbook .SaveAs sPfad & sDatei, CreateBackup:=True .Close End With sDatei = Dir Loop End If ErrHandler: With Application .DisplayAlerts = True .ScreenUpdating = True .EnableEvents = True End With If Err.Number > 0 Then MsgBox Err.Description End Sub

Sub tt() Dim sPfad As String, sDatei As String With Application.FileDialog(4) .AllowMultiSelect = False .InitialFileName = "d:\testarea\" .Title = "Bitte Pfad wählen" .InitialView = 1 If .Show = -1 Then sPfad = .SelectedItems(1) End If End With If sPfad "" Then sPfad = sPfad & "\" sDatei = Dir(sPfad & "*.xls") On Error GoTo ErrHandler With Application .DisplayAlerts = False .ScreenUpdating = False .EnableEvents = False End With Do While sDatei "" Workbooks.Open sPfad & sDatei With ActiveWorkbook .SaveAs sPfad & sDatei, CreateBackup:=True .Close End With sDatei = Dir Loop End If ErrHandler: With Application .DisplayAlerts = True .ScreenUpdating = True .EnableEvents = True End With If Err.Number > 0 Then MsgBox Err.Description End Sub

Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _ ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim Path As String Dim R As Long, x As Long, pos As Integer bInfo.pidlRoot = 0& If IsMissing(Msg) Then bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus." Else bInfo.lpszTitle = Msg End If bInfo.ulFlags = &H1 x = SHBrowseForFolder(bInfo) Path = Space$(512) R = SHGetPathFromIDList(ByVal x, ByVal Path) If R Then pos = InStr(Path, Chr$(0)) GetDirectory = Left(Path, pos - 1) Else GetDirectory = "" End If End Function Sub tt() Dim sPfad As String, sDatei As String sPfad = GetDirectory If sPfad "" Then sPfad = sPfad & "\" sDatei = Dir(sPfad & "*.xls") On Error GoTo ErrHandler With Application .DisplayAlerts = False .ScreenUpdating = False .EnableEvents = False End With Do While sDatei "" Workbooks.Open sPfad & sDatei With ActiveWorkbook .SaveAs sPfad & sDatei, CreateBackup:=True .Close End With sDatei = Dir Loop End If ErrHandler: With Application .DisplayAlerts = True .ScreenUpdating = True .EnableEvents = True End With If Err.Number > 0 Then MsgBox Err.Description End Sub

Sub tt() Dim sPfad As String, sDatei As String With Application.FileDialog(4) .AllowMultiSelect = False .InitialFileName = "d:\testarea\" 'hier wurde auch d:\testarea\001test.xls versucht .Title = "Bitte Pfad wählen" .InitialView = 1 If .Show = -1 Then sPfad = .SelectedItems(1) End If End With If sPfad "" Then sPfad = sPfad & "\" sDatei = Dir(sPfad & "*.xls") On Error GoTo ErrHandler With Application .DisplayAlerts = False .ScreenUpdating = False .EnableEvents = False End With Do While sDatei "" Workbooks.Open sPfad & sDatei With ActiveWorkbook .SaveAs sPfad & sDatei, CreateBackup:=True .Close End With sDatei = Dir Loop End If ErrHandler: With Application .DisplayAlerts = True .ScreenUpdating = True .EnableEvents = True End With If Err.Number > 0 Then MsgBox Err.Description End Sub

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread