AW: Überprüfen ob pdf dat. vorhanden
22.03.2014 19:47:03
Tino
Hallo,
ok. versuche es mal damit.
Es wird für die fehlenden Dateien ein Ordner im Excel Pfad mit dem aktuellen Datum angelegt.
Ist dieser schon vorhanden, werden die Dateien darin gelöscht,
wenn diese nicht gerade verwendet werden.
Sub Find_Fehlende_PDF()
Dim sPfadExcel$, n&, sPfadPDF$, sDir$, sNeuerOrdner$
Dim varPDF(), varExcel()
Dim strFehlt$, nCountF&, nCount&
sPfadExcel = "C:\Daten\Excel\"
sPfadPDF = "C:\Daten\PDF\"
ChDrive sPfadExcel
ChDir sPfadExcel
sDir = Dir(sPfadExcel & "*.xls?", vbNormal)
If sDir = "" Then
MsgBox "keine Excel gefunden"
Exit Sub
End If
'Array groß genug erstellen
ReDim Preserve varPDF(1 To 1000000)
ReDim Preserve varExcel(1 To 1000000)
Do While sDir ""
n = n + 1
varExcel(n) = sDir
varPDF(n) = Left$(sDir, InStrRev(sDir, ".")) & "pdf"
sDir = Dir()
Loop
ReDim Preserve varExcel(1 To n)
ReDim Preserve varPDF(1 To n)
ChDrive sPfadPDF
ChDir sPfadPDF
If n > 0 Then
sNeuerOrdner = NeuerOrdner(sPfadExcel, Format(Date, "dd_mm_yyyy"))
On Error Resume Next
For n = LBound(varPDF) To n
If Dir(CStr(sPfadPDF & varPDF(n)), vbNormal) = "" Then
nCount = nCount + 1
FileCopy sPfadExcel & varExcel(n), sNeuerOrdner & varExcel(n)
If Err.Number 0 Then
nCountF = nCountF + 1
strFehlt = strFehlt & varExcel(n) & vbCrLf
Err.Number = 0
End If
End If
Next n
If nCountF > 0 Then
strFehlt = Left$(strFehlt, Len(strFehlt) - 1)
MsgBox nCountF & " Dateien konnten nicht kopiert werden!" & vbCr & vbCr & _
strFehlt, Title:="PDF nicht gefunden!"
End If
MsgBox nCount - nCountF & " Dateien wurden in den Ordner" & vbCr & vbCr & _
sNeuerOrdner & vbCr & vbCr & _
"kopiert!"
Else
MsgBox "alle gefunden!", vbInformation
End If
End Sub
Function NeuerOrdner(strPath$, OrdnerName$)
Dim s As String
On Error Resume Next
MkDir "" & strPath & OrdnerName & ""
NeuerOrdner = strPath & OrdnerName
NeuerOrdner = NeuerOrdner & IIf(Right$(NeuerOrdner, 1) = "\", "", "\")
If Err.Number 0 Then Kill NeuerOrdner & "*.*"
End Function
Gruß Tino