PDF Dateien kopieren und umbenennen

Hallo zusammen,
ich möchte folgendes Szenario in VBA umsetzen.
Ich habe eine Exceltabelle mit verschiedenen Infos. Relevant sind aber eigentlich nur 4 Spalten. Hier mal ein Beispiel einer Zeile:
A1 = 3971
B1 = 7001
C1 = 0000
AL = 580
A1 bis C1 sollen später verkettet und durch einen Punkt getrennt werden, sprich das Ergebnis muss der String 3971.7001.0000 sein (dieser String soll später der neue Dateiname meiner PDF-Datei werden).
Jetzt möchte ich, dass der User per FilePicker mehrere PDF-Dateien aus dem Verzeichnis C:\Datenblatterzeugung auswählen kann. Die Dateinamen der PDF-Dateien in diesem Verzeichnis besitzen bisher z.B. folgenden Aufbau: 0580 Text.pdf
Nach dem Auswählen der PDF-Dateien soll der VBA Code dafür sorgen, dass die ausgewählten PDF-Dateien kopiert und umbenannt werden. Das soll wie folgt geschehen: Es muss nach den ersten 4 Ziffern des Dateinamens geschaut werden. Ist die erste Ziffer eine 0, soll diese ignoriert werden. Dann muss diese Ziffern Reihenfolge gegen Spalte AL geprüft werden. Gibt es eine Übereinstimmung soll der Dateiname von 0580 Text.pdf in den String 3971.7001.0000.pdf umbenannt werden.
In Spalte AL kann ein Wert auch mehrmals vorkommen, die Kombinationen aus A1 bis C1 sind aber immer unterschiedlich. Der ganze Prozess müsste also in einer Schleife laufen, damit dann die entsprechende Anzahl PDFs kopiert werden (es soll immer 0580 Text.pdf als Basisdatei verwendet werden, der Zieldateiname ändert sich nur jeweils. Es sollen also so viele PDFs kopiert werden, wie es Einträge in der Spalte AL zu dieser Nummer gibt).
0580 dient hier nur als Beispiel, es kommen unterschiedliche Werte vor und daher müssen unterschiedliche PDFs kopiert und umbenannt werden.
Die umbenannten Dateien sollen im Anschluss in das Verzeichnis C:\Datenblatterzeugung\umgewandelt abgelegt werden. Die ursprüngliche Quelldatei im Verzeichnis C:\Datenblatterzeugung soll gelöscht werden.
Ich hoffe ich konnte mein Vorhaben verständlich darstellen. Für Lösungsvorschläge wäre ich sehr dankbar.
Viele Grüße
Patrick

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub umbenennen() Dim Dlg As FileDialog, FSO As Object Dim PfadAlt As String, PfadNeu As String, Datei, TMP Dim Ext As String, DatNeu As String Dim Sp As Integer, Ze As Long PfadAlt = "E:\Excel\temp\Test\" PfadNeu = PfadAlt & "umgewandelt\" Ext = ".pdf" Sp = 38 'Spalte AL Set FSO = CreateObject("Scripting.FileSystemObject") Set Dlg = Application.FileDialog(msoFileDialogFilePicker) With Dlg .AllowMultiSelect = True ' mehrere auswählen möglich .InitialFileName = PfadAlt & "*" & Ext ' Anfangsverzeichnis und Filter .InitialView = msoFileDialogViewDetails 'Anzeige des Dialogs - die Dateien als Detail .Title = "Dateien wählen" End With If Dlg.Show = True Then For Each Datei In Dlg.SelectedItems 'alle gewählten Dateien abarbeiten TMP = CDbl(Replace(Dir(Datei), Ext, "")) 'Datei ohne Pfad, ohne Ext; ohne führende Nullen If WorksheetFunction.CountIf(Columns(Sp), TMP) > 0 Then 'Ist die Datei in AL vorhanden Ze = WorksheetFunction.Match(TMP, Columns(Sp), 0) 'wenn Ja, in welcher Zeile 'neuer Nadeiname DatNeu = Cells(Ze, 1) & "." & Cells(Ze, 2) & "." & Cells(Ze, 3) & Ext 'Umbenennen und verschieben FSO.MoveFile Datei, PfadNeu & DatNeu Set FSO = Nothing End If Next End If End Sub

Option Explicit Sub umbenennen() Dim Dlg As FileDialog, FSO As Object Dim PfadAlt As String, PfadNeu As String, Datei, TMP Dim Ext As String, DatNeu As String Dim Sp As Integer, Ze As Long PfadAlt = "E:\Excel\temp\Test" PfadAlt = PfadAlt & IIf(Right(PfadAlt, 1) = "\", "", "\") 'Prüfen auf \ am Ende If Dir(PfadAlt, vbDirectory) = "" Then MsgBox PfadAlt & ": nicht vorhanden" Exit Sub End If PfadNeu = PfadAlt & "umgewandelt\" If Dir(PfadNeu, vbDirectory) = "" Then MkDir PfadNeu ' wenn nicht da, dann anlegen End If Ext = ".pdf" Sp = 38 'Spalte AL Set FSO = CreateObject("Scripting.FileSystemObject") Set Dlg = Application.FileDialog(msoFileDialogFilePicker) With Dlg .AllowMultiSelect = True ' mehrere auswählen möglich .InitialFileName = PfadAlt & "*" & Ext ' Anfangsverzeichnis und Filter .InitialView = msoFileDialogViewDetails 'Anzeige des Dialogs - die Dateien als Detail .Title = "Dateien wählen" End With If Dlg.Show = True Then For Each Datei In Dlg.SelectedItems 'alle gewählten Dateien abarbeiten TMP = Dir(Datei) 'Datei ohne Pfad If WorksheetFunction.CountIf(Columns(Sp), TMP) > 0 Then 'Ist die Datei in AL vorhanden Ze = WorksheetFunction.Match(TMP, Columns(Sp), 0) 'wenn Ja, in welcher Zeile 'neuer Nadeiname DatNeu = Cells(Ze, 1) & "." & Cells(Ze, 2) & "." & Cells(Ze, 3) & Ext 'Umbenennen und verschieben FSO.MoveFile Datei, PfadNeu & DatNeu End If Next Else MsgBox "Es wurden keine Dateien ausgewählt" End If Set FSO = Nothing End Sub

Danke, das funktioniert schon einmal perfekt. Jetzt haben wir bereits die 95% Lösung. Es fehlt nur noch das i-Tüpfelchen. Das Ganze müsste jetzt noch in einer Schleife oder ähnlichem laufen.
Die Exceldatei kann mehrere Einträge pro PDF-Datei enthalten. Ich versuche mal es zu skizzieren.
Spalte A Spalte B Spalte C Spalte AL
1000 1100 0000 Datei1.pdf
1000 1200 0000 Datei1.pdf
1000 1300 0000 Datei1.pdf
2000 2100 0000 Datei2.pdf
2000 2200 0000 Datei2.pdf
2000 2300 0000 Datei2.pdf
3000 3100 0000 Datei3.pdf
3000 3200 0000 Datei3.pdf
3000 3300 0000 Datei3.pdf
Für Datei1.pdf müssten also 3 Dateien erzeugt werden, ebenso wie für Datei2 und Datei3. Die Namen müssten dann je Zeile variieren.
Viele Grüße
Patrick

Option Explicit Sub Umbenennen() Dim Dlg As FileDialog, FSO As Object Dim PfadAlt As String, PfadNeu As String, Datei, Anz As Long Dim Ext As String, DatNeu As String Dim Sp As Integer, Ze As Long PfadAlt = "E:\Excel\temp\Test\" Ext = ".pdf" Sp = 38 'Spalte AL Set Dlg = Application.FileDialog(msoFileDialogFolderPicker) Dlg.InitialFileName = PfadAlt If Dlg.Show = True Then PfadAlt = Dlg.SelectedItems(1) & "\" PfadNeu = PfadAlt & "umgewandelt\" If Dir(PfadNeu, vbDirectory) = "" Then MkDir PfadNeu ' wenn nicht da, dann anlegen End If LR = Cells(Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte For Ze = 1 To LR Datei = Cells(Ze, Sp) If Dir(PfadAlt & Datei) "" Then 'Datei vorhanden 'neuer Dateiname DatNeu = Cells(Ze, 1) & "." & Cells(Ze, 2) & "." & Cells(Ze, 3) & Ext 'Umbenennen und kopieren Set FSO = CreateObject("Scripting.FileSystemObject") FSO.copyFile PfadAlt & Datei, PfadNeu & DatNeu Anz = Anz + 1 'nochmal vorhanden? If WorksheetFunction.CountIf(Cells(Ze + 1, Sp).Resize(LR - Ze + 1, 1), Datei) = 0 Then 'Wenn Letzte, dann erst löschen FSO.deletefile PfadAlt & Datei End If Else MsgBox Datei & " nicht gefunden" End If Next Else MsgBox "Es wurden kein Pfad ausgewählt" End If MsgBox Anz & " Dateien umbenannt" Set FSO = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

PDF Dateien kopieren und umbenennen

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

PDF Dateien kopieren und umbenennen

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread