Von hinten durch die Brust ins Auge ... :-)
14.03.2005 00:12:26
Ramses
Hallo
Voraussetzung ist, dass die Dateinamen wirklich im Format "01.01.2005.xls" vorliegen
Private Sub CommandButton4_Click()
'(C) by Ramses
'Sortiert Filenamen die im Format "01.01.2005.xls" vorliegen
'korrekt aufsteigend und weist die Liste einer Listbox zu
Dim iCounter As Integer, tmpStr As String
Dim i As Long, Temp As String
With Application.FileSearch
.LookIn = "D:\Rainer"
.FileType = msoFileTypeExcelWorkbooks
.Execute
ReDim FileArr(.FoundFiles.Count)
'Filenamen modifizieren, da die normale Sort-Methode
'nur bis zum ersten Punkt sortiert
For iCounter = 1 To .FoundFiles.Count
tmpStr = Dir(.FoundFiles(iCounter))
tmpStr = WorksheetFunction.Substitute(Left(tmpStr, 10), ".", "")
FileArr(iCounter) = tmpStr
Next iCounter
End With
'Sortierung durchführen
QuickSort FileArr, LBound(FileArr), UBound(FileArr)
'Filenamen rekonstruieren
For i = LBound(FileArr) To UBound(FileArr)
If Len(FileArr(i)) = 7 Then
Temp = Right(FileArr(i), 4)
Temp = Left(Right(FileArr(i), 6), 2) & "." & Temp
Temp = "0" & Left(FileArr(i), 1) & "." & Temp
FileArr(i) = Temp & ".xls"
ElseIf Len(FileArr(i)) = 8 Then
Temp = Right(FileArr(i), 4)
Temp = Left(Right(FileArr(i), 6), 2) & "." & Temp
Temp = Left(FileArr(i), 2) & "." & Temp
FileArr(i) = Temp & ".xls"
End If
Next
'Quot erat demonstrandum
Me.ListBox1.Clear
Me.ListBox1.List = FileArr
End Sub
Der Code muss auch noch mit in die UF.
Der ist aber nicht von mir :-)
Public Sub QuickSort(toSortArray() As String, ByVal LB As Single, ByVal UB As Single)
'String Array sortieren, by ActiveVB
Dim P1 As Single
Dim P2 As Single
Dim ref As String
Dim Temp As String
P1 = LB
P2 = UB
ref = toSortArray((P1 + P2) / 2)
Do
Do While (toSortArray(P1)
P1 = P1 + 1
Loop
Do While (toSortArray(P2) > ref)
P2 = P2 - 1
Loop
If P1
Temp = toSortArray(P1)
toSortArray(P1) = toSortArray(P2)
toSortArray(P2) = Temp
P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)
If LB
If P1
End Sub
Gruss Rainer