Ich habe hier im Archiv folgenden Beitrag gefunden:
https://www.herber.de/forum/archiv/1784to1788/1786970_Dateien_anhand_Liste_suchen_und_kopieren.html
Das löst fast genau mein Problem, aber eben nur fast.
Leider gibt es bei uns sehr sehr lange Ordnerstrukturen. Mit Dateinamen teilweise weit über 250 Zeichen.
Wenn das Macro so einen Ordner trifft gibt er "Laufzeitfehler 53 - Datei nicht gefunden" zurück.
Die Ordner oder Dateien zu kürzen ist leider keine Option.
Gibt es eine Möglichkeit das per code zu umgehen?
Const INPUT_PATH As String = "G:\DATEN\" 'Anpassen !!! Backslash am Ende nicht löschen
Const OUTPUT_PATH As String = "H:\OUTPUT\" '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