pdf sortieren und Ordner erstellen via VBA Teil 2
30.07.2019 01:53:13
Tom
leider kann ich nicht mehr auf meinen alten Beitrag antworten, daher erstelle ich jetzt einen neuen.
Franz (oder auch fcs), erstmal vielen Dank fuer deine Hilfe. Ich hoffe mein Dank erreicht dich auf irgendeine Weise.
Franz hat mir folgenden Code geschrieben:
--------------------------------------------------------
Sub PDF_Sortieren()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim wksFiles As Worksheet, wkbFiles As Workbook
Dim lngZei As Long
Dim sNeu As String
Dim bolMove As Boolean
Dim varFolder As Variant
Dim sPS As String
sPS = Application.PathSeparator
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner mit den PDF-Dateien auswählen"
If .Show = -1 Then
varFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
Set objFSO = VBA.CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.getFolder(varFolder)
Set wkbFiles = ActiveWorkbook
Set wksFiles = wkbFiles.Worksheets("Liste")
With wksFiles
lngZei = .Cells(.Rows.Count, 1).End(xlUp).Row
If lngZei > 3 Then
.Range(.Rows(4), .Rows(lngZei)).ClearContents
End If
End With
lngZei = 3
For Each objFile In objFolder.Files
If LCase(VBA.Right(objFile.Name, 3)) = "pdf" Then
If Len(objFile.Name) >= 14 Then
' If IsNumeric(Left(Right(objFile.Name, 14), 10)) Then
lngZei = lngZei + 1
wksFiles.Cells(lngZei, 1) = "'" & objFile.Name
wksFiles.Cells(lngZei, 2) = objFile.Datelastmodified
wksFiles.Cells(lngZei, 3) = "'" & Left(Right(objFile.Name, 14), 10)
wksFiles.Cells(lngZei, 4) = "'" & Left(Right(objFile.Name, 14), 10) & " " _
& Format(objFile.Datelastmodified, "YYYY-MM-DD")
' End If
End If
End If
Next
If lngZei > 3 Then
If lngZei > 4 Then
With wksFiles
.Columns.AutoFit
With .Range(.Cells(3, 1), .Cells(lngZei, 5))
.Sort key1:=.Range("D1"), order1:=xlAscending, _
key2:=.Range("A1"), Order2:=xlAscending, Header:=xlYes
End With
End With
End If
With wksFiles
For lngZei = 4 To .Cells(.Rows.Count, 1).End(xlUp).Row
If sNeu varFolder & sPS & .Cells(lngZei, 4).Text Then
sNeu = varFolder & sPS & .Cells(lngZei, 4).Text
If Dir(sNeu, vbDirectory) "" Then
bolMove = False
MsgBox "Verzeichnis """ & sNeu & """ ist bereits vorhanden"
Else
bolMove = True
VBA.MkDir Path:=sNeu
End If
End If
If bolMove = True Then
Set objFile = objFSO.getfile(varFolder & sPS & .Cells(lngZei, 1).Text)
objFile.Move sNeu & sPS & objFile.Name
.Cells(lngZei, 5).Value = "verschoben"
Else
.Cells(lngZei, 5).Value = "Verzeichnis vorhanden"
End If
Next
End With
Else
MsgBox "keine PDF-Dateien gefunden, die verschoben werden"
End If
wksFiles.Cells(1, 2) = varFolder
wksFiles.Activate
End Sub
------------------------------------------------
Ziel war es, pdf Dateien in einem Quellordner abzuspeichern und anhand des Namens (Name aus 14 Zeichen, wo nur die letzten 10 Zahlen genommen werden) und des Erstelldatums in neue Unterordner zu sortieren. Die sortierten Ordner werden zusaetzlich noch in einer Excelliste abgelegt.
Das Ergebnis sieht dann in etwas wie folgt aus:
1027779802 2019-07-15
1028020928 2019-07-26
1027966518 2019-07-26
1028020933 2019-07-26
1028020933 2019-07-29
Meine Idee war es zusaetzlich Dopplungen zu erkennen bzw. zu vermeiden. Dies gelingt allerdings nur wenn ich doppelte Dateien am gleichen Tag im Quellordner ablege. Lege ich schon vorhandene Dateien an spaeteren Tagen ab wird ein neuer Ordner gebildet (siehe Beispiel fettgedruckt)
Frage 1: Wie schaffe ich es meinen Code so anzupassen, dass nur die Nummer (unabhaengig vom Datum) ueberprueft wird und eine Fehlermeldung angezeigt wird?
(Beispiel fettgedruckt: Der Ordner 1028020933 existiert bereits)
Frage 2: Ich habe festgestellt dass es auch 7- bzw. 10-stellige Zahlenkombinationen geben kann. Kann ich einfach Teile des Codes kopieren und anpassen? Wenn ja welche?
Frage 3: Die erstellten Ordner werden in einer Excel gepflegt. So wie der Code jetzt funktioniert, ueberschreibt er die Daten in der Excel bei neuer Anwendung. Wie schaffe ich es, dass die Liste fortgefuehrt wird.
Ich bedanke mich schon einmal fuer die Unterstuetzung!!
Viele Gruesse aus Australien,
Tom