Office: Dateinamen per VBA auslesen und Dateinamen umbenennen

Hallo zusammen,

ich habe folgendes Problem und bin über die eine und andere hilfreiche Antwort sehr dankbar.

Ich habe eine Ordnerstruktur im Microsoft Explorer. Innerhalb der Ordner befinden sich Word-, Excel-, pdf-Dateien. Die Dateinamen habe alle eine unterschiedliche Länge und sind beispielsweise wie folgt benannt:

beispiel_1__#836381169v1.doc
Wm2010_#740580734v1.xls
Bundespräsident_#948680760v1.pdf
etc

Ich möchte innerhalb der Dateinamen die Zeichenkette _#836381169v1 etc entfernen. Da in den 60 Unterordnern über 200 Dateien vorhanden ist, wäre eine manueller Umbenennung sehr mühsehlig. Daher dachte ich mir, dass es bestimmt ein VBA Makro gibt, welches folgende Schritte kann.

1. Schritt: Das Makro soll alle Dateinamen und Dateipfade, also pro Zeile ein Dateiname und ein Dateipfad in Excel schreiben. Hierbei ist wichtig, dass das Makro auch Unterordner durchsucht und quasi alle Ebenen einbezieht.

2. Schritt: Ich (also kein Makro) könnte dann neben den ausgelesenen Pfad und ursprünglichen Dateinamen per Excel Formel (links, rechts, länge) die Zeichenkette entfernen und den neuen Dateinamen in die Excelzelle neben den ursprünglichen Namen schreiben. Der neue Name wäre dann in der selben Zeile wie der aktuelle (ursprüngliche Name) und der Dateipfad.

3. Schritt: Das Makro nimmt nun den neuen Dateinamen, sucht per Pfad den ursprünglichen Dateinamen und benennt den Dateinamen um.

Nach meiner Theorie wäre dann die Arbeit getan. Da ich ein Laie bin im Bereich VBA Programmierung, wäre ich über eine Hilfestellung sehr dankbar, wie ich das Problem löse und ob mein Vorschlag überhaupt praktisch umzusetzen wäre.

Falls der Sachverhalt nicht deutlich ist, stehe ich für Rückfragen gerne zur Verfügung.

Vielen Dank vorab

Beste Grüße
Alexwee

:)

 

Hallo Alex,

hier ein Code ohne den Umweg über die Tabelle.


' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub findAndRename()
Dim objFiles() As Object, lngRet As Long, lngIndex As Long
Dim strNewName As String

lngRet = FileSearchINFO(objFiles, "E:\Temp", "*", True) 'Pfad anpassen!

If lngRet > 0 Then
For lngIndex = 0 To lngRet - 1
If objFiles(lngIndex).Name Like "*_?#########v1.*" Then
strNewName = Left(objFiles(lngIndex).Name, InStr(1, objFiles(lngIndex).Name, "_#") - 1) & _
Mid(objFiles(lngIndex).Name, InStrRev(objFiles(lngIndex).Name, "."))

Name objFiles(lngIndex) As objFiles(lngIndex).ParentFolder.Path & "\" & strNewName
End If
Next
End If

End Sub

Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long

'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)


Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant

Set fobjFSO = CreateObject("Scripting.FileSystemObject")

Set ffsoFolder = fobjFSO.GetFolder(InitialPath)

On Error GoTo ErrExit

If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
Redim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
Redim Preserve Files(UBound(Files) + 1)
Else
Redim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next

If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If

If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function


Gruß Sepp

 

Hallo Sepp,

besten Dank. Mit solch einer Antwort hätte ich niemals gerechnet.

Ich hatte wegen meiner mangelnden Kenntnis etwas Probleme das Makro zum laufen zu bringen, aber als es dann endlich lief, ging es wunderbar!!!

Keine Probleme und nochmals vielen Dank für den hervorragenden Support!

Viele Grüße
Alex

 

Hallo Sepp

Super Makro echt!! Und nach ein bisschen herumtüfteln, ist auch der Aufbau klar *Smilie

Habe jetzt aber noch ein kleines Problem, das löschen der Dateiendung hat einwandfrei funktioniert, jetzt möchte ich aber noch an einer gewissen Stelle eine Anzahl Nullen einfügen.

Beispiel:

Der Name der Datei sieht so aus:

01-177-1_doc-74837483

Nach deinem Makro was einwandfrei funktioniert so:

01-177

Jetzt müsste ich allerdings an dritter Stelle von hinten noch zwei Nullen haben, so das es dann so aussieht:

01-00177

Es müsste immer an dritter Stelle von hinten eingefügt werden, da der Dateinamen auch so aussehen kann

01-077 (nach den eingefügten Nullen: 01-00077)

oder so:

01-007 (nach den eingefügten Nullen: 01-00007)

Falls du mir da weiter helfen könntest wäre ich dir sehr dankbar. *Smilie

Gruss
21n0

 

Hallo Josef,

ganz großes Kino. Vielen Dank dafür. Mache zwar auch einiges mit VBA, aber diese Ecke habe ich noch nicht beackert, scheint sich zu lohnen.