Ordnerinhalte auslesen - Code langsam

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

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

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

Ordnerinhalte auslesen - Code langsam

Ordnerinhalte auslesen - Code langsam von Frank vom 24.10.2020 02:25:14

AW: Ordnerinhalte auslesen - Code langsam - von ChrisL am 24.10.2020 07:48:07
AW: Ordnerinhalte auslesen - Code langsam - von volti am 24.10.2020 09:08:27
- AW: Ordnerinhalte auslesen - Code langsam - von Frank am 26.10.2020 16:51:49
- AW: Ordnerinhalte auslesen - Code langsam - von Frank am 26.10.2020 16:52:25
  - AW: Ordnerinhalte auslesen - Code langsam - von volti am 26.10.2020 17:28:59
    - AW: Ordnerinhalte auslesen - Code langsam - von Frank am 26.10.2020 20:05:47
      - AW: Ordnerinhalte auslesen - Code langsam - von volti am 27.10.2020 08:14:13

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