Hallo,
teste mal, habe es nicht getestet, müsste mir erst die Umgebung schaffen.
Option Explicit
Dim ErsteZelle As Range
Dim sGrundPfad As String
Sub Read_Write_Files_In_Folder()
Dim VonDatum As Date, BisDatum As Date
Dim sOJahr As String, sOMonat As String
Range("A2", Cells(Rows.Count, 1)).Value = ""
VonDatum = "01.01.2009 03:07:00" 'Datum von
BisDatum = "02.01.2009 23:59:59" 'Datum bis
'hier Grundpfad angeben ohne \ am ende
sGrundPfad = "C:\Start"
'erste Zelle, ab welcher Zelle einfügen?
Set ErsteZelle = Range("A2")
With Application
.StatusBar = "Lese Daten, bitte warten..."
.ScreenUpdating = False
'Pfad anpassen
'Pfad, VonDatum, BisDatum, Dateiformat, mit Unterordner, kompl. Pfad u. Datei
ListFilesInFolder sGrundPfad, VonDatum, BisDatum, "*_20##_##_##_##_##_##.txt", True, True
.ScreenUpdating = True
.StatusBar = False
End With
End Sub
Sub ListFilesInFolder(SourceFolderName As String, DatumVon As Date, DatumBis As Date, Optional DateiFormat As String = "*.*", Optional IncludeSubfolders As Boolean = False, Optional FolderName As Boolean = False)
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Dim FileName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error GoTo Err_Zugriff: 'sollte Ordener geschützt sein
If DatumOrdner(DatumVon, DatumBis, SourceFolderName) Then
For Each FileItem In SourceFolder.Files
If LCase(FileItem) Like LCase(DateiFormat) Then
FileName = Right$(FileItem, Len(FileItem) - InStrRev(FileItem, "\"))
If FunctionDatum(FileName) >= DatumVon And FunctionDatum(FileName) <= DatumBis Then
ErsteZelle.Value = IIf(FolderName, FileItem, FileName)
Set ErsteZelle = ErsteZelle.Offset(1, 0)
End If
End If
Next FileItem
End If
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, DatumVon, DatumBis, DateiFormat, IncludeSubfolders, FolderName
Next SubFolder
End If
Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub
Private Function FunctionDatum(strText As String) As Date
Dim strTXT As String, strTXT2 As String
Dim Datum As Date
On Error GoTo Fehler:
strTXT = Right$(strText, Len(strText) - InStr(strText, "_" & Year(Date)))
strTXT2 = Replace(Right$(strText, Len(strTXT) - 11), ".txt", "")
strTXT2 = Replace(strTXT2, "_", ":")
strTXT = Replace(Left$(strTXT, 10), "_", ".")
FunctionDatum = CDate(strTXT) + TimeValue(strTXT2)
Exit Function
Fehler:
FunctionDatum = 0
End Function
Function DatumOrdner(DatumVon As Date, DatumBis As Date, sPfad As String) As Boolean
Dim Datum As Date, stempPfad As String, sDatum As String
stempPfad = Replace(sPfad, sGrundPfad, "")
If Len(stempPfad) < 11 Then
DatumOrdner = False
Exit Function
Else
stempPfad = Left$(stempPfad, 11)
stempPfad = Right$(stempPfad, Len(stempPfad) - 1)
sDatum = Right$(stempPfad, 2) & "."
sDatum = sDatum & Mid$(stempPfad, 6, 2) & "."
sDatum = sDatum & Left$(stempPfad, 4)
Datum = CDate(sDatum)
If Datum >= Int(DatumVon) And Datum <= Int(DatumBis) Then
DatumOrdner = True
Exit Function
End If
End If
DatumOrdner = False
End Function
Gruß Tino