Sub Kopieren_Xl_aus_Unterordner()
Dim i As Long
Dim ZielPath As String
Dim QuellPath As String
Dim NewPath As String
Dim SuchStr As String
QuellPath = "C:\Users\Administrator\Documents\Ablage\Excel\Peter\Zeiterfassung\import\"
ZielPath = "C:\Users\Administrator\Documents\Ablage\Excel\Peter\Zeiterfassung\aktuell\"
SuchStr = "*.xl*"
With Application.FileSearch
.NewSearch
.LookIn = QuellPath
.SearchSubFolders = True
.Filename = SuchStr
.MatchTextExactly = False
.Execute
For i = 1 To .FoundFiles.Count
NewPath = Left(.FoundFiles(i), Len(.FoundFiles(i)) - Len(Dir(.FoundFiles(i))))
NewPath = ZielPath & Right(NewPath, Len(NewPath) - Len(QuellPath))
If CheckDir(NewPath) = False Then
MsgBox "Kopieren fehlgeschlagen!"
Exit Sub
Else
FileCopy .FoundFiles(i), ZielPath & Right(.FoundFiles(i), Len(.FoundFiles(i)) - Len(QuellPath))
End If
Next
End With
End Sub
Function CheckDir(ByVal Verzeichnis As String) As Boolean
Dim i As Integer
Dim strNewVerzeichnis As String
If Right(Verzeichnis, 1) <> "\" Then Verzeichnis = Verzeichnis & "\"
On Error GoTo CheckDIR_Exit
i = InStr(4, Verzeichnis, "\")
Do While i > 0
strNewVerzeichnis = Left(Verzeichnis, i)
If Len(Dir(strNewVerzeichnis, vbDirectory)) = 0 Then MkDir (strNewVerzeichnis)
i = InStr(i + 1, Verzeichnis, "\")
Loop
CheckDIR_Exit:
CheckDir = (Err.Number = 0)
End Function