pdf sortieren und Ordner erstellen via VBA Teil 3
29.08.2019 05:16:04
Tom
Ich habe einen Code mithilfe des Forums (grosses Dankeschoen an Franz bzw. fcs) erarbeitet und verwende ihn seit einigen Wochen.
Mittlerweile sind mir einige Probleme aufgefallen, die ich nicht geloest bekomme.
Ich sortiere mithilfe des Makros mehrere pdf Dateien und erstelle damit zugehoerige Ordner.
Hier ein Beispiel:
123-1028525344.pdf
456-1028525344.pdf
123-1028773196.pdf
456-1028773196.pdf
789-1028773196.pdf
123-1098569840.pdf
Daraus sollten 3 Ordner entstehen, bestehend aus Nummer und aktuellem Datum:
1028525344 2019-08-29 (sollte 2 Dateien beinhalten)
1028773196 2019-08-29 (sollte 3 Dateien beinhalten)
1098569840 2019-08-29 (sollte 1 Datei beinhalten)
Allerdings habe ich manchmal das Problem, dass nicht alle Dateien verschoben werden. Beispielsweise befinden sich dann nur folgende Dateien in den Ordnern:
1028525344 2019-08-29 (sollte 1 Dateien beinhalten)
1028773196 2019-08-29 (sollte 2 Dateien beinhalten)
1098569840 2019-08-29 (sollte 1 Datei beinhalten)
Es werden manchmal Dateien nicht erkannt und nicht verschoben, leider Weiss ich nicht woran es liegt, da die bezeichnungen der Dateien korrekt sind.
Hier ist mein Code:
-------------------------------
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
End With
'Einlesen der PDF-Dateinamen im ausgewählten Ordner
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
With wksFiles
.Cells(1, 2).ClearContents
.Columns.AutoFit
If lngZei > 4 Then
With .Range(.Cells(3, 1), .Cells(lngZei, 7))
.Sort key1:=.Range("G1"), order1:=xlAscending, _
key2:=.Range("A1"), Order2:=xlAscending, Header:=xlYes
End With
End If
For lngZei = 4 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(lngZei, 5).Text = "" Then
If sNeu varFolder & sPS & .Cells(lngZei, 4).Text Then
sNeu = varFolder & sPS & .Cells(lngZei, 4).Text
If Dir(varFolder & sPS & .Cells(lngZei, 3).Text _
& " ?-?-?", vbDirectory) "" Then
bolMove = False
MsgBox "Verzeichnis """ & varFolder & sPS & .Cells(lngZei, 3).Text _
& " ?-?-?" & """ 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"
.Cells(lngZei, 6).Value = "Ausdrucken!"
.Cells(lngZei, 7).Value = objFile.DateCreated
Else
.Cells(lngZei, 5).Value = "Verzeichnis vorhanden"
.Cells(lngZei, 6).Value = "Ueberpruefen!"
End If
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
---------------------------------
Vielleicht hat jemand einen Rat woran es liegen kann, dass das Makro mal funktioniert und mal nicht.
Vielen Dank im Voraus und viele Gruesse
Tom