Dateien anhand Liste suchen und kopieren

Public Sub CopyFiles()
Const INPUT_PATH As String = "W:\Vault_Wustec\CAD\Projekte\" 'Anpassen !!! Backslash am _
Ende nicht löschen
Const OUTPUT_PATH As String = "C:\Users\wustec\Desktop\Test-Ziel\" 'Anpassen !!! _
Backslash am Ende nicht löschen
Dim astrFolders() As String, strFilename As String
Dim avntValues As Variant, vntItem As Variant
Dim ialngFolders As Long, ialngIndex As Long, lngCount As Long
Dim objDictionary As Object
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
Range(Cells(2, 2), Cells(Rows.Count, 2)).ClearContents
avntValues = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Value2
With objDictionary
For ialngIndex = LBound(avntValues) To UBound(avntValues)
If Not .Exists(Key:=avntValues(ialngIndex, 1)) Then
Call .Add(Key:=avntValues(ialngIndex, 1), Item:=ialngIndex + 1)
Else
Cells(ialngIndex + 1, 2).Value = "X"
End If
Next
astrFolders = GetFolders(INPUT_PATH)
For Each vntItem In .Keys
lngCount = 0
For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
strFilename = Dir$(astrFolders(ialngFolders) & vntItem & "*.pdf")
If strFilename  vbNullString Then
Call FileCopy(Source:=astrFolders(ialngFolders) & strFilename, Destination:= _
_
OUTPUT_PATH & strFilename)
lngCount = 1
End If
strFilename = Dir$(astrFolders(ialngFolders) & vntItem & "*.dwg")
If strFilename  vbNullString Then
Call FileCopy(Source:=astrFolders(ialngFolders) & strFilename, Destination:= _
_
OUTPUT_PATH & strFilename)
lngCount = lngCount + 1
End If
If lngCount = 2 Then Exit For
Next
If lngCount = 0 Then
Cells(.Item(Key:=vntItem), 2).Value = 0
Else
Cells(.Item(Key:=vntItem), 2).Value = 1
End If
Next
End With
Set objDictionary = Nothing
End Sub

Private Function GetFolders(ByVal pvstrPath As String) As String()
Dim astrFolders() As String
Dim strFolder As String, strPath As String
Dim ialngIndex1 As Long, ialngIndex2 As Long
ReDim Preserve astrFolders(ialngIndex1)
astrFolders(ialngIndex1) = pvstrPath
ialngIndex1 = 1
ialngIndex2 = 1
strPath = pvstrPath
Do
strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
Do Until strFolder = vbNullString
If strFolder  "." And strFolder  ".." Then
If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
ReDim Preserve astrFolders(0 To ialngIndex1)
astrFolders(ialngIndex1) = strPath & strFolder & "\"
ialngIndex1 = ialngIndex1 + 1
End If
End If
strFolder = Dir$
Loop
If ialngIndex1 = ialngIndex2 Then Exit Do
strPath = astrFolders(ialngIndex2)
ialngIndex2 = ialngIndex2 + 1
Loop
GetFolders = astrFolders
End Function