Ordnerinhalte auslesen - Code langsam
24.10.2020 02:25:14
Frank
ich habe ein kleines Problem.
Vielleicht kann mir jemand dabei helfen.
ich möchte gerne Daten aus einem Ordner auslesen (Name der Datei, Speicherdatum und Größe der Datei).
Ich habe mal ein wenig im Internet geschaut und dann einmal was zusammen geschrieben.
Das ganze funktioniert auch alles soweit, wie ich es haben möchte, aber mein Problem ist, das das auslesen der Daten immer lange dauert.
ich habe Ordner mit vielleicht 300 Dateien und Ordner mit vielleicht 700 Dateien.
Leider dauert das auslesen der Ordner immer so lange (10-15 sek.)
Kann man das beschleunigen?
kann man den Code anpassen was vielleicht effektiver ist?
danke schon einmal im Voraus
Frank
Code:
Sub DateienAuflisten()
Dim strPfad As String
Dim lngZeile, letzte As Long
Dim strDatei As String
Dim x, y, z As String
Application.ScreenUpdating = False
letzte = Cells(Rows.Count, 1).End(xlUp).Row
Cells(2, 4).Value = 0
Cells(2, 5).Value = 0
Cells(2, 6).Value = 0
If letzte > 1 Then
x = MsgBox("Daten vorher löschen?", vbYesNo + vbCritical, "Abfrage")
If x = 6 Then 'ja
lngZeile = letzte + 1
Range(Cells(4, 1), Cells(2000, 3)).ClearContents
Range(Cells(4, 8), Cells(2000, 8)).ClearContents
Range(Cells(4, 12), Cells(2000, 12)).ClearContents
Range(Cells(4, 16), Cells(2000, 16)).ClearContents
Range(Cells(4, 20), Cells(2000, 20)).ClearContents
Range(Cells(4, 24), Cells(2000, 24)).ClearContents
Range(Cells(4, 28), Cells(2000, 28)).ClearContents
Range(Cells(4, 32), Cells(2000, 32)).ClearContents
lngZeile = 4
Else 'nein
lngZeile = letzte + 1
End If
Else
lngZeile = 4
End If
Do
strPfad = GetFolder
strDatei = Dir(strPfad & "\*.*")
If strPfad "" Then
Cells(1, 1) = "Seriennummmer"
Cells(1, 2) = "Datum / Uhrzeit"
Cells(1, 3) = "Größe in KB"
Do
Cells(lngZeile, 1) = strDatei
Cells(lngZeile, 2) = FileDateTime(strPfad & "\" & strDatei)
Cells(lngZeile, 3) = Round(FileLen(strPfad & "\" & strDatei) / 1024, 2)
strDatei = Dir
lngZeile = lngZeile + 1
x = 1
Loop While strDatei ""
End If
z = MsgBox("noch meher Daten auslesen?", vbYesNo + vbInformation, "Auslesen")
If z 6 Then
Exit Do
End If
Loop
ActiveWorkbook.Worksheets("Test").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Test").AutoFilter.Sort.SortFields.Add Key:= _
Range("B3:B" & lngZeile), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("Test").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Cells(2, 4).FormulaLocal = "=ANZAHL2($A$4:$A$2000)"
Cells(2, 5).FormulaLocal = "=WENN(D2=0;0;D2-(SUMMENPRODUKT(($C$4:$C$2000>RUNDEN(MITTELWERT($ _
C$4:$C$2000);1)-0,5)*($C$4:$C$2000Function GetFolder() As String
Dim x As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
x = InputBox("Bitte Pfad auswählen" & vbLf & vbLf & _
"1 = Test1" & vbLf & vbLf & _
"2 = Test2" & vbLf & _
"3 = Test3" & vbLf & vbLf & _
"4 = Test4", "Pfadauswahl")
If Not IsNumeric(x) Then
MsgBox "Auswahl fehlerhaft. Bitter erneut probierren", vbOKOnly + vbCritical, " _
Falshe Auswahl"
Exit Function
ElseIf x = "1" Then
.InitialFileName = "D:\Test1\" 'Startordner anpassen!!
ElseIf x = "2" Then
.InitialFileName = "D:\Test2\" 'Startordner anpassen!!
ElseIf x = "3" Then
.InitialFileName = "D:\Test3\" 'Startordner anpassen!!
ElseIf x = "4" Then
.InitialFileName = "D:\Test4\" 'Startordner anpassen!!
Else
MsgBox "Auswahl fehlerhaft. Bitter erneut probierren", vbOKOnly + vbCritical, " _
Falshe Auswahl"
Exit Function
End If
.ButtonName = "OK"
.Title = "Dateiauswahl"
.Show
If .SelectedItems.Count = 0 Then
GetFolder = ""
Else
GetFolder = .SelectedItems(1)
End If
End With
End Function