01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44 |
|
Option Explicit
Private Declare PtrSafe Function SHCreateDirectoryExW Lib "shell32" ( _
ByVal hwnd As LongPtr, ByVal pszPath As LongPtr, _
ByVal psa As LongPtr) As Long
Sub DateienKopieren()
Dim sFile As String, sSuch As String, iAnz As Integer
Dim vGefunden As Variant, FSO As Object
Const csQuelPath As String = "C:\Users\volti\Documents\Adobedokumente\" ' <<<anpassen>>>
Const csZielPath As String = "C:\Users\volti\Documents\Archiv\" ' <<<anpassen>>>
CreateDirectory csZielPath ' Zielpfad erstellen (Optional)
Set FSO = CreateObject("Scripting.FileSystemObject") ' Objektvariable setzen
sFile = Dir$(csQuelPath & "*.pdf") ' Dateisuchmaske auf PDF setzen
Do While sFile <> "" ' Gesamten Order durchsuchen
With ThisWorkbook.Sheets("Fundus") ' Blatt referenzieren
sSuch = Replace(sFile, ".pdf", "", 1, 1) ' Erw. .PDF abtrennen
vGefunden = Application.Match(sSuch, .Range("A:A"), 0)
If IsError(vGefunden) Then
FSO.CopyFile csQuelPath & sFile, csZielPath & sFile ' Datei kopieren
With .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) ' Daten eintragen
.Value = sSuch
.Offset(0, 1).Value = "Daten aus Ordner " & csQuelPath
iAnz = iAnz + 1 ' Kopierte Dateien zählen
End With
End If
End With
sFile = Dir$ ' Nächste Datei auslesen
Loop
Set FSO = Nothing ' Objekt zerstören
MsgBox iAnz & " Dateien wurden kopiert!", vbInformation, "Dateien kopieren"
End Sub
Private Function CreateDirectory(ByVal sFullPath As String) As Long
CreateDirectory = SHCreateDirectoryExW(0&, StrPtr(sFullPath), 0&)
End Function
|