VisualBasic Macro um Dateinamen zu aendern

[gwaihir]

Hallo,

ich brauchte ein Programm, dass wir Dateinamen anhand einer Excel-Tabelle veraendert.

As-Is:
Windows Ordern-Struktur mit
- Ordnername = Nummer in Excel Tabelle
- Dateiname = Aplhanumerisch
Diese Dateien sind .pdf-Files.

Ausserdem habe ich ein Excel File, dass folgende Spezifikation aufweist:
[table="width: 500"]
[tr]
[td]Nummer[/td]
[td]Alphanummerisch[/td]
[td]Datum [/td]
[/tr]
[tr]
[td]Wert 1[/td]
[td]Wert 2[/td]
[td]Datum 1[/td]
[/tr]
[tr]
[td]Wert 3[/td]
[td]Wert 4[/td]
[td]Datum 1[/td]
[/tr]
[tr]
[td]etc.[/td]
[td]etc.[/td]
[td]etc.[/td]
[/tr]
[/table]

Der alphanumerische Wert kann als eindeutige Identifikation verwendet werden. Diese Wert existiert nur einmal und kann gesucht werden.

Folgende Funktion soll das Programm haben:
- Die Dateien in der Ordnerstruktur muessen umbeannt werden: Nummer_Alphanumerisch_Datum
- Die Dateien muessen zusammen in einen Order kopiert werden.

Da ich auf meinem PC keine Admin-Rechte besitzt waere es mir recht wenn wir ein VBA Makro schreiben koennten.

Als Beispiel:
- Ordner '1234567890' --> Datei 'W12345'
- Excel Datei
[table="width: 500"]
[tr]
[td]Nummer[/td]
[td]Alphanummerisch[/td]
[td]Datum [/td]
[/tr]
[tr]
[td]1234567890[/td]
[td]W12345[/td]
[td]01.01.2018[/td]
[/tr]
[/table]
- Datei sollte kopiert werden in separaten Ordner mit Name 1234567890_W12345_01.01.2018.pdf


Habt ihr irgendwelche Ideen aussehen koennten? Fehlen euch irgendwelche Informationen, die euch helfen?

Gruesse und vielen Dank
Kai

 

[Alchemist]

Hallo,

mein erster Treffer bei Google mit "VBA Ordner umbennen" leitet mich direkt hier hin: http://www.herber.de/forum/archiv/564to568/567372_Verzeichnis_umbenennen.html
Das hier passt noch besser: http://www.herber.de/forum/archiv/376to380/379394_Dateien_per_VBA_kopieren_ueberschreiben.html

Vielleicht schreibst du schon mal ein bisschen Code, dann gucken wir was nicht klappt.

Viele Grüße.

P.S. Geht mit Dateien genauso, hab es gerade selber getestet.

 

[gwaihir]

Alles klar mache ich. Danke!

 

[gwaihir]

Hallo,

das ist was ich bisher habe. Probleme habe ich noch damit die Variable tFile zu bestimmen. Habt ihr eine Idee wie ich ueber die Folderstruktur sowie die Excel Tabelle das korrekte File bestimmen kann? Dazu brauche ich eine Schleife, die solange prueft, bis sie das richtige File mit dem gleichen alphanumerischen Wert gefunden hat.

Sub RenameMove()

Dim myFSO As Object
Dim qFolder As String, tFolder As String
Dim qFile As String, tFile As String
Dim i As Long

For i = 1 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row ' erste bis letzte Zeile des aktiven Blattes
qFile = Worksheets("Source").Cells(i, 1).Value ' Datiename setzen Hier wurde ich ein =CONCATENATE( in die Excel Tabelle setzen
tFile =
qFolder = "C:\"
tFolder = "C:\new\"
Set myFSO = CreateObject("Scripting.FileSystemObject")
myFSO.CopyFile qFolder & qFile, tFolder & tFile, True
Next ' nächsten Wert der Schleife

End Sub

Gruesse und danke
Kai

 

[gwaihir]

Jemand eine Idee?

 

[Alchemist]

Hi,

sorry habs erst jetzt gesehen.

So wie ich deinen Anfangspost verstanden habe, steht doch alter und neuer Dateiname in derselben Zeile.
Um Missverständnisse zu vermeiden:
qFolder: Quellordner
qFile: Datei mit falschem Dateinamen, dieser steht in deiner Tabelle unter "Alpahnumerisch"
tFolger: Zielordner
tFile: Zieldateiname, bei dir die Kombi: Ordner_Alphanum_Datum.pdf

Hier der Link zur Methode: https://msdn.microsoft.com/en-us/library/aa265015(v=vs.60).aspx

tFile kannst du direkt im Programm bestimmen, es handelt sich hierbei ja um Strings, also Texte, diese können in VBA mittels & verbunden werden.
Also zB. Cells(i,1)&"_"&Cells(i,2)&"_"&Cells(i,3)&".pdf"
Für qFile kannst du es also genauso machen: qFile = Cells(i,1).value & ".pdf"

Achso und bei dem Next fehlt i

Deine Vorgehensweise im Moment ist ja, dass du alle in der Excel aufgeführten Dateien verschiebst. Es würden am Ende die Dateien überbleiben, die nicht in der Tabelle stehen.

Ich hoffe das hat etwas geholfen.

 

[gwaihir]

Hallo,

so wie ich verstehe, erwartest du das alle Dateien zwischen Excel und Orderstruktur in der selben Reihenfolge sind oder? Das ist nicht so.

Ausserdem kann es Dateien in der Ordner-Struktur geben, die es nicht im Excel gibt und andersrum. Deswegen muss irgendeine Schleife laufen, die die Verbindung zwischen Excel und Order-Struktur herstellt/identifiziert.

Das heisst wir sollten qFile aus der Ordner-Struktur holen und nicht aus dem Ecxel-File.

Was meinst du?

Neuer Code:

Sub RenameMove()
 
Dim myFSO As Object
Dim qFolder As String, tFolder As String
Dim qFile As String, tFile As String
Dim i As Long
 
For i = 1 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row ' erste bis letzte Zeile des aktiven Blattes
qFile = qFile = Cells(i, 1).Value & ".pdf"
tFile = Worksheets("Source").Cells(i, 1) & "_" & Cells(i, 2) & "_" & Cells(i, 3) & ".pdf" ' Datiename setzen Hier wurde ich ein =CONCATENATE( in die Excel Tabelle setzen
qFolder = "C:\"
tFolder = "C:\new\"
Set myFSO = CreateObject("Scripting.FileSystemObject")
myFSO.CopyFile qFolder & qFile, tFolder & tFile, True
Next i ' nächsten Wert der Schleife
 
End Sub

 

[Alchemist]

Ausserdem kann es Dateien in der Ordner-Struktur geben, die es nicht im Excel gibt und andersrum. Deswegen muss irgendeine Schleife laufen, die die Verbindung zwischen Excel und Order-Struktur herstellt/identifiziert.

Naaaa dann wird das nicht so einfach:

 Option Explicit
Private strList(999999, 1) As String
Dim varFolder As Variant
Private lngCount As Long
Dim strTMP As String
Dim i, j As Long

Dim myFSO As Object
Dim tFolder As String
Dim tFile As String

tFolder = "C:\Test\" 'Hier sollen die Dateien hin 

Public Sub Test()
    lngCount = 0
    strTMP = GetFolder()
    'strTMP = "C:\Test\" ' so für festen Pfad
    If strTMP = "" Or Left(strTMP, 1) = ":" Then Exit Sub
    SearchFiles strTMP, "*.*", True 'anpassen zb *.pdf
    'SearchFiles strTMP, "*.ppt" 'so OHNE Unterordner
    If lngCount = 0 Then
        MsgBox "No file found"
        Exit Sub
    End If

        For i = 0 To UBound(strList, 1)
        'HIER musst du ran, in strList stehen jetzt alle gefundenen Dateien
          For j = 1 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
            
            If Cells(j, 2) & ".pdf" = strList(i, 1) Then
                'Übereinstimmung gefunden
                tFile = Worksheets("Source").Cells(j, 1) & "_" & Cells(j, 2) & "_" & Cells(j, 3) & ".pdf"
                Set myFSO = CreateObject("Scripting.FileSystemObject")
                myFSO.CopyFile strList(i, 0) & "\" & strList(i, 1), tFolder & tFile, True
                Exit For
            End If
            Next j
            'Man kann noch in einem extra Tabellenblatt alle gefundenen Ordner und Dateien auflisten:
           ' With Worksheets("NAME")
                '.Cells(i + 1, 1) = strList(i, 0) 'liefert Ordner Name
                '.Cells(i + 1, 2) = strList(i, 1)   'liefert Dateiname
           ' End With
          If strList(i, 0) = "" Then Exit For 'wenn leer, dann keine Dateien mehr gefunden -> aufhören
        Next i

    Set varFolder = Nothing
End Sub
Private Function GetFolder() As String
    Dim objShell As Object
    Dim strPath As String
    Set objShell = CreateObject("Shell.Application")
    Set varFolder = objShell.BrowseForFolder(0, "Folder", &H4000, 17)
    If varFolder Is Nothing Then
        Set varFolder = Nothing
        Set objShell = Nothing
        Exit Function
    End If
    GetFolder = varFolder.Self.Path
    Set objShell = Nothing
End Function

Private Sub SearchFiles(strFolder As String, strFileName As String, Optional blnSubFolder As Boolean = False)
    Dim objFolder As Object
    Dim objFile As Object
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName Then
            'ReDim Preserve strList(lngCount, 1)
            strList(lngCount, 0) = strFolder
            strList(lngCount, 1) = objFile.Name
            lngCount = lngCount + 1
        End If
    Next
    If blnSubFolder = True Then
        For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
            SearchFiles strFolder & "\" & objFolder.Name, strFileName
        Next objFolder
    End If
End Sub

Hier passiert eine ganze Menge, dich muss aber nur der Teil interessieren, wo der Kommentar steht. Beim Ausführen suchst du den Überordner aus, ab da werden alle Unterordner durchsucht. Du kannst "*.*" zB durch "*.pdf" ersetzen, um nur pdf Dateien zu suchen. Die Stelle ist per Kommentar im Code gekennzeichnet.
Werden keine Dateien gefunden, wird ein Fehler angezeigt. Wenn Dateien vorhanden sind, werden sowohl Ordner als auch Dateiname im strList Array gespeichert. strList(i,0) enthält den Ordnernamen, strList(i,1) den Dateinamen. Hieraus bastel ich dann auch die Quelle für die Verschiebeanweisung. tFolder und tFile musst du noch definieren.
Die If Anweisung in Kombination mit der j Schleife durchsucht alle vorhandenen Zeilen in Spalte 2 (ANPASSEN) nach dem Dateinamen, wenn dieser gefunden wurde, werden die Aktionen gestartet. Hier kannst du rumprobieren, was eigentlich passieren soll. Der Grundstein ist aber gelegt.
Ich verstehe leider nicht, was du genau machen willst. Irgendwo muss schon stehen, was mit den Dateien passieren soll, wenn sie nicht in der excel stehen, werden sie auch nicht verschoben, wohin auch, bzw anhand welcher Kriterien?
Aber ich denke, so hast du schon mal eine Grundlage bezüglich der Ordner.

 

[gwaihir]

Wow, das hilft eine Menge. Vielen Dank! Ich schaue mir den Code an und versuche ihn gemaess meiner Anforderungen anzupassen.

Wenn Dateien in Excel nicht gefunden werden, waere es perfekt eine Art Error Log in ein neues Tabellenblatt zu schreiben.

Das gleiche waere toll wenn Dateien in Excel sind, aber in der Ordnerstruktur nicht gefunden werden koennen.

Ist sowas moeglich?

 

[Alchemist]

Gerne, war auch für mich ganz interessant, sich damit mal zu beschäftigen

Ich würde ganz einfach ein neues Tabellenblatt anlegen, in das du alle alle gefundenen Dateien einträgst, diese stehen ja in deiner strList. Der Anfang steht ja bereits im Code:

 With Worksheets("NAME")
                '.Cells(i + 1, 1) = strList(i, 0) 'liefert Ordner Name
                '.Cells(i + 1, 2) = strList(i, 1)   'liefert Dateiname
                '.Cells(i + 1, 3) = strList(i, 2)   'liefert Neuen Pfad mit Namen
           ' End With

Dazu kannst du dann noch ergänzend den neuen Namen schreiben in dem du die strList um in der zweiten Dimension um eins erweiterst, also am Anfang

 Private strList(999999, 2) As String

und hier kannst du dann beim Umbenennen den neuen Namen dazuschreiben:

 If Cells(j, 2) & ".pdf" = strList(i, 1) Then
                'Übereinstimmung gefunden
                tFile = Worksheets("Source").Cells(j, 1) & "_" & Cells(j, 2) & "_" & Cells(j, 3) & ".pdf"
                Set myFSO = CreateObject("Scripting.FileSystemObject")
                strList(i,2)= tFolder & tFile
                myFSO.CopyFile strList(i, 0) & "\" & strList(i, 1), tFolder & tFile, True
                Exit For
            End If

Du siehst dann, wenn der Neuename leer ist, dass kein Eintrag gefunden wurde. Ich würde persönlich immer von msgboxen absehen, da sie extrem unhandlich sein können, wenn davon 10 oder gar 100 aufpoppen und du jede wegklicken musst.

In deinen Quelldaten kannst du zB eine Spalte anfügen, die einfach einen Wert enthält, der dir zeigt, dass der Eintrag genutzt wurde. Alle ohne Markierung wurden entsprechend nicht gefunden. Die Zeile kennst du ja aus obigem Code mit j, in der der passende Eintrag gefunden wurde. Ich würde in die Markierungsspalte dann einfach 1 schreiben, wenn gefunden. Dann kannst du danach filtern.

Ich hoffe das hilft weiter

 

[gwaihir]

Habe mir gerade nochmal das Volumen angeschaut. Es geht um
18.937 Dateien in
1.006 Ordnern.

Ich mach dann mal weiter den Code zusammen zu bauen und zu testen.

 

[Alchemist]

Hi,

ist eigentlich noch was raus gekommen bei deinen Versuchen? Würde mich schon interessieren

 

[gwaihir]

Ich melde mich!