Alle Unterordner durchsuchen

Sub ZeichnungsverteilungJAG()
'Zeichnungsverteilung im Projektordner JAG
'Quellverzeichnisse
Const quellVerzeichnis As String = "\\proj-srv.kroegerwerft.de\Projekte\JAG\Technische_Unterlagen\Zeichnungen\Fertige Zeichnungen\"
'Zielverzeichnisse
Const verzeichnisPMA     As String = "\\kroegerwerft.de\pub\Teams\Zeichnungsverteilung\PMA\"
Const verzeichnisRockson As String = "\\kroegerwerft.de\pub\Teams\Zeichnungsverteilung\Rockson\"
Const verzeichnisBesecke As String = "\\kroegerwerft.de\pub\Teams\Zeichnungsverteilung\Besecke\"
Const verzeichnisWSAM    As String = "\\kroegerwerft.de\pub\Teams\Zeichnungsverteilung\WSAM\"
'Archivverzeichnis
Const verzeichnisPMA_Archiv     As String = "\\kroegerwerft.de\pub\Teams\Zeichnungsverteilung\Archiv\PMA\"
Const verzeichnisRockson_Archiv As String = "\\kroegerwerft.de\pub\Teams\Zeichnungsverteilung\Archiv\Rockson\"
Const verzeichnisBesecke_Archiv As String = "\\kroegerwerft.de\pub\Teams\Zeichnungsverteilung\Archiv\Besecke\"
Const verzeichnisWSAM_Archiv    As String = "\\kroegerwerft.de\pub\Teams\Zeichnungsverteilung\Archiv\WSAM\"
'Empfänger
Dim empfaenger1 As String
Dim empfaenger2 As String
'Dateiname
Dim dateinameQuelle As String
Dim dateinameZiel   As String
Dim dateinameArchiv As String
Dim strFileName     As String
'Zeichnungsnummer
Dim zeichnungNummer As Range
Dim vntOrdnerListe, vntOrdner
'Wildcard Zwischenspeicher
Dim i As Long
Dim alleDateienStr As String
Dim alleDateienVar As Variant
Call OrdnerListe(quellVerzeichnis, vntOrdnerListe)
'Abgleich der Zeichnungsnummer mit dem Dateinamen
Dim FSO As Object, oFile As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each zeichnungNummer In Range("A5:A" & Cells(Rows.Count, "A").End(xlUp).Row)
empfaenger1 = zeichnungNummer.Offset(0, 7)
empfaenger2 = zeichnungNummer.Offset(0, 8)
strFileName = vbNullString
'Spalte "W" kontrollieren
If zeichnungNummer  "" Then
For Each vntOrdner In vntOrdnerListe
strFileName = Dir(vntOrdner & "\*" & Replace(zeichnungNummer, "X", "?") & "*.pdf", vbNormal)
If Len(strFileName) Then
alleDateienStr = ""
While strFileName  ""
'Dateinamen zwischenspeichern falls Wildcards verwendet werden
alleDateienStr = alleDateienStr & strFileName & "|"
strFileName = Dir()
Wend
alleDateienVar = Split(alleDateienStr, "|")
For i = LBound(alleDateienVar) To UBound(alleDateienVar) - 1
strFileName = alleDateienVar(i)
dateinameQuelle = vntOrdner & "\" & strFileName
'Datei ins zielVerzeichnis1 kopieren
Select Case LCase(empfaenger1)
Case "pma"
dateinameZiel = verzeichnisPMA & strFileName
dateinameArchiv = verzeichnisPMA_Archiv & strFileName
Case "rockson"
dateinameZiel = verzeichnisRockson & strFileName
dateinameArchiv = verzeichnisRockson_Archiv & strFileName
Case "besecke"
dateinameZiel = verzeichnisBesecke & strFileName
dateinameArchiv = verzeichnisBesecke_Archiv & strFileName
Case "wsam"
dateinameZiel = verzeichnisWSAM & strFileName
dateinameArchiv = verzeichnisWSAM_Archiv & strFileName
End Select
If Not DateiExistiert(dateinameZiel) And Not DateiExistiert(dateinameArchiv) Then
On Error Resume Next
FileCopy dateinameQuelle, dateinameZiel
End If
'Datei ins zielVerzeichnis2 kopieren
Select Case LCase(empfaenger2)
Case "pma"
dateinameZiel = verzeichnisPMA & strFileName
dateinameArchiv = verzeichnisPMA_Archiv & strFileName
Case "rockson"
dateinameZiel = verzeichnisRockson & strFileName
dateinameArchiv = verzeichnisRockson_Archiv & strFileName
Case "besecke"
dateinameZiel = verzeichnisBesecke & strFileName
dateinameArchiv = verzeichnisBesecke_Archiv & strFileName
Case "wsam"
dateinameZiel = verzeichnisWSAM & strFileName
dateinameArchiv = verzeichnisWSAM_Archiv & strFileName
End Select
If Not DateiExistiert(dateinameZiel) And Not DateiExistiert(dateinameArchiv) Then
On Error Resume Next
FileCopy dateinameQuelle, dateinameZiel
End If
Next i
Exit For 'damit nicht weiter nach der Nummer gesucht wird
End If
Next vntOrdner
End If
Next zeichnungNummer
End Sub
Sub OrdnerListe(strFolder As String, vntOrdnerListe)
Dim FSO As Object, oSuFo As Object
Dim oFolder As Object, oDictF As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(strFolder)
Set oDictF = CreateObject("Scripting.dictionary")
oDictF(strFolder) = 0
For Each oSuFo In oFolder.subfolders
oDictF(oSuFo.Path) = 0
Call prcSubFolders(oSuFo, oDictF)
Next oSuFo
vntOrdnerListe = oDictF.keys
End Sub
Sub prcSubFolders(oFolder, oDictF)
Dim oSubFolder As Object
For Each oSubFolder In oFolder.subfolders
oDictF(oFolder.Path) = 0
prcSubFolders oSubFolder, oDictF
Next
End Sub
Public Function DateiExistiert(strDatei As String)
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strDatei) = True Then
DateiExistiert = True
Else
DateiExistiert = False
End If
Set objFSO = Nothing
End Function