Unterverzeichnisse mit durchsuchen?
14.02.2022 15:02:05
Patrick
ich habe ein Makro, das Dateien von einem Quellverzeichnis in verschiedene Zielverzeichnisse kopiert. Im Quellverzeichnis wird dafür nach bestimmten Dateien gesucht und bei einem Match, wird die Datei kopiert. Bisher funktioniert das aber nur für das Quellverzeichnis selbst, nicht für Unterverzeichnisse.
Sub Dateien_Kopieren()
'Kopiert Dateien für Projekt A
'Variablendeklaration
Const quellVerzeichnis As String = "C:\Zeichnungen_Quelle\"
Const verzeichnisPMA As String = "C:\Zeichnungen_Test_PMA\"
Const verzeichnisRockson As String = "C:\Zeichnungen_Test_Rockson\"
Const verzeichnisBesecke As String = "C:\Zeichnungen_Test_Besecke\"
Const verzeichnisWSAM As String = "C:\Zeichnungen_Test_WSAM\"
'Empfänger
Dim empfaenger1 As String
Dim empfaenger2 As String
empfaenger1 = Cells(4, 5)
empfaenger2 = Cells(4, 6)
'Dateiname
Dim dateinameQuelle As String
Dim dateinameZiel As String
'Zeichnungsnummer
Dim zeichnungNummer As Range
'Abgleich der Zeichnungsnummer mit dem Dateinamen
Dim fso As Object, oFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each oFile In fso.GetFolder(quellVerzeichnis).Files
For Each zeichnungNummer In Range("A4:A" & Cells(Rows.Count, "A").End(xlUp).Row)
If zeichnungNummer "" Then
If InStr(oFile.Name, zeichnungNummer) Then
dateinameQuelle = quellVerzeichnis & oFile.Name
'Datei ins zielVerzeichnis1 kopieren
Select Case LCase(empfaenger1)
Case "pma"
dateinameZiel = verzeichnisPMA & oFile.Name
Case "rockson"
dateinameZiel = verzeichnisRockson & oFile.Name
Case "besecke"
dateinameZiel = verzeichnisBesecke & oFile.Name
Case "wsam"
dateinameZiel = verzeichnisWSAM & oFile.Name
End Select
If Not DateiExistiert(dateinameZiel) Then
FileCopy dateinameQuelle, dateinameZiel
End If
'Datei ins zielVerzeichnis1 kopieren
Select Case LCase(empfaenger2)
Case "pma"
dateinameZiel = verzeichnisPMA & oFile.Name
Case "rockson"
dateinameZiel = verzeichnisRockson & oFile.Name
Case "besecke"
dateinameZiel = verzeichnisBesecke & oFile.Name
Case "wsam"
dateinameZiel = verzeichnisWSAM & oFile.Name
End Select
If Not DateiExistiert(dateinameZiel) Then
FileCopy dateinameQuelle, dateinameZiel
End If
End If
End If
empfaenger1 = zeichnungNummer.Offset(1, 4)
empfaenger2 = zeichnungNummer.Offset(1, 5)
Next zeichnungNummer
Next oFile
End Sub
Function DateiExistiert(Dateipfad As String) As Boolean
'Zu prüfender String
Dim TestString As String
TestString = ""
On Error Resume Next
TestString = Dir(Dateipfad)
On Error GoTo 0
If TestString = "" Then
DateiExistiert = False
Else
DateiExistiert = True
End If
End Function
Viele Grüße
Patrick