AW: dafür gibt es besseres ...
11.01.2019 16:02:17
UweD
Hallo nochmal
dann wird es was aufwändiger..
Hier das Makro (oberer Teil) plus 3 Subroutionen
Sub Umbenennen()
'mit Rekursion zum Lesen der Unterordner
Dim Startpfad As String, Ext As String, Leer As Integer
Dim Daten As New Collection 'gesammelte Ergebinsse
Dim Eintrag, Datum As Date, Anz As Integer
Dim ii As Long, TempPfad As String, Datei As String, Neuname As String
Startpfad = "X:Temp\Test"
Ext = ".pdf"
'alle Dateien sammeln
Call ListFilesInFolder(Daten, Startpfad, True)
'nichts gefunden
If Daten.Count = 0 Then
MsgBox ("In Ordner " & Startpfad & " Nichts gefunden.")
Exit Sub
End If
'Ergebnis filtern, z. B. nur Excel-Dateien zulassen
For ii = Daten.Count To 1 Step -1
If InStr(Dateiendung_von(Daten(ii)), Ext) <> 1 Then
Daten.Remove ii
End If
Next ii
'Die eigendliche Arbeit folgt hier
For Each Eintrag In Daten
TempPfad = Pfadname_von(Eintrag)
Datei = Dateiname_von(Eintrag)
Leer = InStr(Datei, " ") 'Leerzeichenposition
If Leer > 0 Then
If IsDate(Left(Datei, Leer - 1)) Then
Datum = Left(Datei, Leer - 1)
Neuname = TempPfad & "\" & Format(Datum, "YYYY-MM-DD") & Mid(Datei, Leer)
If Eintrag <> Neuname Then
Name Eintrag As Neuname
Anz = Anz + 1
End If
End If
End If
Next Eintrag
MsgBox "Fertig: " & Anz & " Dateien umbenannt"
End Sub
Sub ListFilesInFolder(Daten As Collection, SourceFolderName As String, _
IncludeSubfolders As Boolean)
'alle Dateien in SourceFolder auflisten
'Beispiel: ListFilesInFolder "C:\FolderName\", True
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim SourceFolder, SubFolder, FileItem
Set SourceFolder = FSO.GetFolder(SourceFolderName)
For Each FileItem In SourceFolder.Files
Daten.Add FileItem.Path
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder Daten, SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Function Pfadname_von(aa) As String
'Pfadname abtrennen
Pfadname_von = Left(aa, InStrRev(aa, "\") - 1)
End Function
Function Dateiname_von(aa) As String
'Dateiname abtrennen
Dateiname_von = Mid(aa, InStrRev(aa, "\") + 1)
End Function
Stammt Großteils von http://www.office-loesung.de/ftopic256109_0_0_asc.php
LG UweD