Option Explicit
Private Type TUDFileInfo
Idx1 As Integer
Idx2 As Integer
Date As Date
Name As String
Path As String
Extension As String
End Type
Public Sub Test()
Const C_FOLDER As String = "X:\Verzeichnis\Unterverzeichnis"
Const C_FILEINFO_ARRAY_INCR As Long = 6
Dim audfi() As TUDFileInfo
Dim strFile As String
Dim i As Long
ReDim audfi(1 To C_FILEINFO_ARRAY_INCR)
i = LBound(audfi)
strFile = Dir$(C_FOLDER & "\*.csv")
Do Until strFile = ""
If GetUDFileInfo(C_FOLDER & "\" & strFile, audfi(i)) Then
i = i + 1
If i > UBound(audfi) Then
ReDim Preserve audfi(1 To UBound(audfi) + C_FILEINFO_ARRAY_INCR)
End If
End If
strFile = Dir$()
Loop
If i = LBound(audfi) Then
Call MsgBox("Keine CSV-Dateien in '" & C_FOLDER & "' gefunden", vbExclamation)
Else
ReDim Preserve audfi(1 To i - 1)
i = LBound(audfi)
If Sort(audfi) Then
For i = LBound(audfi) To UBound(audfi)
With audfi(i)
Debug.Print .Idx1, .Idx2, Format$(.Date, "yy-mm-dd")
End With
Next
Call MsgBox("Fertig.", vbInformation)
Else
Call MsgBox("Sortieren ist fehlgeschlagen", vbCritical)
End If
End If
Erase audfi
End Sub
Private Function Sort(UDFileInfo() As TUDFileInfo) As Boolean
Dim wks As Excel.Worksheet
Dim rngRow As Excel.Range
Dim blnSU As Boolean
Dim blnDA As Boolean
Dim i As Long
blnSU = Application.ScreenUpdating
Application.ScreenUpdating = False
blnDA = Application.DisplayAlerts
Application.DisplayAlerts = False
On Error GoTo ErrHandler
Set wks = Worksheets.Add
For i = LBound(UDFileInfo) To UBound(UDFileInfo)
Set rngRow = wks.Range("A" & i & ":F" & i)
With UDFileInfo(i)
rngRow.Value = Array(.Idx1, .Idx2, Format$(.Date, "'yyyy-mm-dd"), .Path, .Name, .Extension)
End With
Next
With wks.Range("A" & LBound(UDFileInfo) & ":F" & UBound(UDFileInfo))
Call .Sort(Key1:=.Cells(1, 1), _
Key2:=.Cells(1, 2), _
Key3:=.Cells(1, 3), _
Header:=xlNo)
For i = 1 To .Rows.Count
Set rngRow = .Range("A" & i & ":F" & i)
With UDFileInfo(i)
.Idx1 = rngRow.Cells(1).Value
.Idx2 = rngRow.Cells(2).Value
.Date = CDate(rngRow.Cells(3).Value)
.Path = rngRow.Cells(4).Value
.Name = rngRow.Cells(5).Value
.Extension = rngRow.Cells(6).Value
End With
Next
End With
Sort = True
SafeExit:
If Not wks Is Nothing Then
Call wks.Delete
Set wks = Nothing
End If
Application.DisplayAlerts = blnDA
Application.ScreenUpdating = blnSU
Exit Function
ErrHandler:
GoTo SafeExit
End Function
Private Function GetUDFileInfo(Filename As String, ByRef UDFileInfo As TUDFileInfo) As Boolean
With UDFileInfo
If InStrRev(Filename, "\") > 0 Then
.Path = Trim$(Left$(Filename, InStrRev(Filename, "\")))
.Name = Mid$(Filename, Len(.Path) + 1, Len(Filename) - Len(.Path))
Else
.Path = ""
.Name = Trim$(Filename)
End If
If InStrRev(.Name, ".") > 0 Then
.Extension = Right$(.Name, Len(.Name) - InStrRev(.Name, "."))
.Name = Left$(.Name, Len(.Name) - Len(.Extension) - 1)
End If
If Not .Name Like "Z##_Z##_D######" Then Exit Function
.Idx1 = Mid(.Name, 2, 2)
.Idx2 = Mid(.Name, 6, 2)
.Date = CDate(Format$(Right$(.Name, 6), "\2\000-00-00"))
End With
GetUDFileInfo = True
End Function