Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Ordnerinhalte auslesen - Code langsam

Betrifft: Ordnerinhalte auslesen - Code langsam von: Frank
Geschrieben am: 24.10.2020 02:25:14

Hallo an alle,

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$2000
    Function 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

  • Betrifft: AW: Ordnerinhalte auslesen - Code langsam
    von: ChrisL
    Geschrieben am: 24.10.2020 07:48:07

    Hi Frank

    Evtl. hilft:
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
            .DisplayAlerts = False
            .Calculation = xlManual
        End With
    
    ' Code
    
        With Application
           .ScreenUpdating = True
           .EnableEvents = True
           .DisplayAlerts = True
           .Calculation = xlAutomatic
        End With

    Oder mal probieren, ob es mit Power-Query schneller ginge:
    https://www.youtube.com/watch?v=FT67j2o9mOg

    cu
    Chris

    Betrifft: AW: Ordnerinhalte auslesen - Code langsam
    von: volti
    Geschrieben am: 24.10.2020 09:08:27

    Hallo Frank,

    neben der von Chris schon genannten Erweiterung, kann man die gefundenen Daten auch erst in ein Array einfügen und dann in einem Rutsch ausgeben.

    Hier mal ein Muster zur Auflistung von Dateien incl. Unterordner in dem das praktiziert wird.
    Probiere selbst mal, ob es ein Zeitgewinn ist und sich lohnen würde....

    Code:
    [Cc][+][-]
     
    Sub FileSearchList() 'Auflisten von gefilterten Dateien aus Ordner und Unterordner Dim OutZeile As Long, sArr() As String, sPath As String sPath = "D:\" AnzZl = 0 FileOut OutZeile, sArr, CreateObject("scripting.filesystemobject").GetFolder(sPath) With ThisWorkbook.Sheets("Dateien") .Cells.ClearContents .Cells(1, 1).Resize(1, 4).value = Split("Pfad Dateiname Datum, Größe") .Cells(2, 1).Resize(OutZeile, 4).value = Application.Transpose(sArr()) End With MsgBox OutZeile & " Dateien gefunden!", vbInformation, "Dateisuche" End Sub Sub FileOut(i As Long, sArr, oPath As Object) Dim oFile As Object, oDir As Object, Obj As Variant On Error Resume Next For Each oFile In oPath.Files 'Ordner durchsuchen If Err = 0 Then With oFile Err = 0 ReDim Preserve sArr(3, i) DoEvents sArr(0, i) = Replace(.Path, "\" & .Name, "") sArr(1, i) = .Name 'Dateinamen im Direktfenster ausgeben sArr(2, i) = FileDateTime(.Path) sArr(3, i) = .Size i = i + 1 End With End If Next For Each oDir In oPath.Subfolders 'Unterordner durchsuchen Obj = FileDateTime(oDir) FileOut i, sArr, oDir Next End Sub
     
    ____________________
    viele Grüße aus Freigericht
    Karl-Heinz


    Betrifft: AW: Ordnerinhalte auslesen - Code langsam
    von: Frank
    Geschrieben am: 26.10.2020 16:51:49

    Hallo Karl-Heinz,

    danke dafür das klappt wirklich super und ist super schnell.

    jetzt habe ich nur ein Problem.

    kann man den Code so gestalten, dass das "Ordnerfenster" aufgeht, und ich den Unterordner auswählen kann den ich brauch

    Bsp.:

    "D:/Test" der Pfad soll lauf gehen - hier habe ich dann 10 Unterordner und ich möchte dann per klick den Ordner auswählen, den ich auch haben will

    also so wie ich des bei meiner "GetFolder" Funktion habe

    danke

    Frank

    Betrifft: AW: Ordnerinhalte auslesen - Code langsam
    von: Frank
    Geschrieben am: 26.10.2020 16:52:25

    Hallo Karl-Heinz,

    danke dafür das klappt wirklich super und ist super schnell.

    jetzt habe ich nur ein Problem.

    kann man den Code so gestalten, dass das "Ordnerfenster" aufgeht, und ich den Unterordner auswählen kann den ich brauch

    Bsp.:

    "D:/Test" der Pfad soll lauf gehen - hier habe ich dann 10 Unterordner und ich möchte dann per klick den Ordner auswählen, den ich auch haben will

    also so wie ich des bei meiner "GetFolder" Funktion habe

    danke

    Frank

    Betrifft: AW: Ordnerinhalte auslesen - Code langsam
    von: volti
    Geschrieben am: 26.10.2020 17:28:59

    Hallo Frank,

    da kannst Du doch Deine schon erprobte GetFolder-Funktion nehmen:

    Habe mir erlaubt, die mal ein bisschen anzupassen und ins meinen Code eingebaut.
    Code:
    [Cc][+][-]

    Option Explicit Function GetFolder() As String 'Ordnerauswahl With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False Select Case InputBox("Bitte Pfad auswählen" & vbLf & vbLf & _ "1 = Test1" & vbLf & vbLf & _ "2 = Test2" & vbLf & _ "3 = Test3" & vbLf & vbLf & _ "4 = Test4", "Pfadauswahl") Case "1": .InitialFileName = "D:\Test1\" 'Startordner anpassen Case "2": .InitialFileName = "D:\Test2\" 'Startordner anpassen Case "3": .InitialFileName = "D:\Test3\" 'Startordner anpassen Case "4": .InitialFileName = "D:\Test4\" 'Startordner anpassen Case Else MsgBox "Die Auswahl ist fehlerhaft. Bitte erneut probieren", _ vbCritical, "Falsche Auswahl" Exit Function End Select .ButtonName = "OK" .Title = "Ordnerauswahl" .Show If .SelectedItems.Count = 0 Then GetFolder = "" Else GetFolder = .SelectedItems(1) End If End With End Function Sub FileSearchList() 'Auflisten von gefilterten Dateien aus Ordner und Unterordner Dim OutZeile As Long, sArr() As String, sPath As String sPath = GetFolder() If sPath = "" Then Exit Sub AnzZl = 0 FileOut OutZeile, sArr, CreateObject("scripting.filesystemobject").GetFolder(sPath) With ThisWorkbook.Sheets("Dateien") .Cells.ClearContents .Cells(1, 1).Resize(1, 4).value = Split("Pfad Dateiname Datum, Größe") .Cells(2, 1).Resize(OutZeile, 4).value = Application.Transpose(sArr()) End With MsgBox OutZeile & " Dateien gefunden!", vbInformation, "Dateisuche" End Sub Sub FileOut(i As Long, sArr, oPath As Object) Dim oFile As Object, oDir As Object, Obj As Variant On Error Resume Next For Each oFile In oPath.Files 'Ordner durchsuchen If Err = 0 Then With oFile Err = 0 ReDim Preserve sArr(3, i) DoEvents sArr(0, i) = Replace(.Path, "\" & .Name, "") sArr(1, i) = .Name 'Dateinamen im Direktfenster ausgeben sArr(2, i) = FileDateTime(.Path) sArr(3, i) = .Size i = i + 1 End With End If Next For Each oDir In oPath.Subfolders 'Unterordner durchsuchen Obj = FileDateTime(oDir) FileOut i, sArr, oDir Next End Sub

    ____________
    viele Grüße 😊
    Karl-Heinz


    Betrifft: AW: Ordnerinhalte auslesen - Code langsam
    von: Frank
    Geschrieben am: 26.10.2020 20:05:47

    Hallo Karl-Heinz,

    danke dir.

    habe noch ein wenig rum gebastelt, dass alles soweit funktioniert.

    jetzt bin ich auf eine komische Sache gestoßen:
    in der 3. Spalte soll er mir die Größe der Daten ausgeben, macht es ja auch soweit, aber Excel erkennt das nicht als Zahl. wenn ich mit der Maus Doppelklick in die Zelle mache und wieder rausklicke, erst dann erkennt Excel das ganze als Zahl.

    das ist voll komisch.

    hast du eine Idee?


    grüße Frank

    Betrifft: AW: Ordnerinhalte auslesen - Code langsam
    von: volti
    Geschrieben am: 27.10.2020 08:14:13

    Hallo Frank,

    bei mir sind es Zahlen....

    Aber ggf. mal das Array nicht als String, sondern als Variant dimensionieren. Wenn das nicht hilft, ggf. die Spalte vorher als Zahlen formatieren. Vielleicht ist das bei Dir ja als Text eingestellt.

    Code:
    [Cc][+][-]

    Option Explicit Dim AnzZl As Integer Function GetFolder() As String 'Ordnerauswahl With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False Select Case InputBox("Bitte Pfad auswählen" & vbLf & vbLf & _ "1 = Test1" & vbLf & vbLf & _ "2 = Test2" & vbLf & _ "3 = Test3" & vbLf & vbLf & _ "4 = Test4", "Pfadauswahl") Case "1": .InitialFileName = "D:\Test1\" 'Startordner anpassen Case "2": .InitialFileName = "D:\Test2\" 'Startordner anpassen Case "3": .InitialFileName = "D:\Test3\" 'Startordner anpassen Case "4": .InitialFileName = "D:\Test4\" 'Startordner anpassen Case Else MsgBox "Die Auswahl ist fehlerhaft. Bitte erneut probieren", _ vbCritical, "Falsche Auswahl" Exit Function End Select .ButtonName = "OK" .Title = "Ordnerauswahl" .Show If .SelectedItems.Count = 0 Then GetFolder = "" Else GetFolder = .SelectedItems(1) End If End With End Function Sub FileSearchList() 'Auflisten von gefilterten Dateien aus Ordner und Unterordner Dim OutZeile As Long, vArr() As Variant, sPath As String sPath = GetFolder() If sPath = "" Then Exit Sub AnzZl = 0 FileOut OutZeile, vArr, CreateObject("scripting.filesystemobject").GetFolder(sPath) With ThisWorkbook.Sheets("Dateien") .Cells.ClearContents .Cells(1, 1).Resize(1, 4).Value = Split("Pfad Dateiname Datum, Größe") .Cells(2, 1).Resize(OutZeile, 4).Value = Application.Transpose(vArr()) End With MsgBox OutZeile & " Dateien gefunden!", vbInformation, "Dateisuche" End Sub Sub FileOut(i As Long, vArr, oPath As Object) Dim oFile As Object, oDir As Object, Obj As Variant On Error Resume Next For Each oFile In oPath.Files 'Ordner durchsuchen If err = 0 Then With oFile err = 0 ReDim Preserve vArr(3, i) DoEvents vArr(0, i) = Replace(.Path, "\" & .Name, "") vArr(1, i) = .Name 'Dateinamen im Direktfenster ausgeben vArr(2, i) = FileDateTime(.Path) vArr(3, i) = .Size i = i + 1 End With End If Next For Each oDir In oPath.Subfolders 'Unterordner durchsuchen Obj = FileDateTime(oDir) FileOut i, vArr, oDir Next End Sub

    ____________
    viele Grüße 😊
    Karl-Heinz


    Beiträge aus dem Excel-Forum zum Thema "Ordnerinhalte auslesen - Code langsam"