Hallo

anbei ein doppelter Code zum auflisten eines ganzen Ordners.  Das 1. Makro erwartet in Zelle C1 den Pfad+Ordnername, in F1 kann man den Dateityp angeben.

Das 2. Makro öffnet einen Auswahl Dialog, wo man die Datei frei waehlen kann.  Leider kann man hier keine Beispieldatei hochladen.  Tabelle selbst einrichten.

mfg  Nobody

Option Explicit     'myDir Makro aus dem Internet
'überarbeitete Version von Nobody   27.12.2016
Dim sPfad As String, temp As String


'1. Makro listet aus Zelle C1 auf
'listet Ordner -ohne- UnterOrdner

Sub myDir_auflisten()
Dim Opt As Variant, n As Integer
Dim Dtyp As String, z As Integer
   On Error GoTo Fehler
   Range("C2:C4") = Empty
   Range("A5:E1000").Clear
   Dtyp = Range("F2").Value
   If Dtyp = "" Then Dtyp = "*.*"
   sPfad = Range("C1").Value
   temp = Dir(sPfad & "\" & Dtyp)
   
   If InStr(Dtyp, ".") = 0 Then MsgBox _
      "Ungültiger Dateitup, Punkt fehlt": Exit Sub

   'einen Ordner auflisten
   Do While temp <> ""
      z = z + 1:  n = n + 1
      Cells(z + 4, 2) = z
      Cells(z + 4, 3) = temp
      Cells(z + 4, 4) = FileLen(sPfad & "\" & temp)
      Cells(z + 4, 5) = FileDateTime(sPfad & "\" & temp)
      temp = Dir
   Loop

   If n > 0 Then Range("A5") = " " & n & " Dateien"
   If n = Empty Then [c2] = "Ordner No Find / Leer, oder Dateityp ungültig"
   
   Range("A2").Value = Now
   Range("B5", [b5].End(xlDown)).HorizontalAlignment = xlCenter
Exit Sub

Fehler: MsgBox "unerwarteter Fehler - Abbruch"
End Sub


'2. Makro:  Ordner Auswahl über Dialogfeld

Sub myDir_Auswäahlen()
Dim Opt As Variant, n As Integer
Dim Dtyp As String, z As Integer
   'Ordner Auswahl über Dialogfeld
   With Application.FileDialog(msoFileDialogFolderPicker)
     .AllowMultiSelect = False
      If .Show = 0 Then Exit Sub
      sPfad = .SelectedItems(1)
   End With

   On Error GoTo Fehler
   Range("C2:C4") = Empty
   Range("A5:E1000").Clear
   Range("C3") = sPfad
   Dtyp = Range("F2").Value
   If Dtyp = "" Then Dtyp = "*.*"
   temp = Dir(sPfad & "\" & Dtyp)
   
   If InStr(Dtyp, ".") = 0 Then MsgBox _
      "Ungültiger Dateitup, Punkt fehlt": Exit Sub

   'einen Ordner auflisten
   Do While temp <> ""
      z = z + 1:  n = n + 1
      Cells(z + 4, 2) = z
      Cells(z + 4, 3) = temp
      Cells(z + 4, 4) = FileLen(sPfad & "\" & temp)
      Cells(z + 4, 5) = FileDateTime(sPfad & "\" & temp)
      temp = Dir
   Loop

   If n > 0 Then Range("A5") = " " & n & " Dateien"
   If n = Empty Then [c2] = "Ordner No Find / Leer, oder Dateityp ungültig"
   
   Range("A2").Value = Now
   Range("B5", [b5].End(xlDown)).HorizontalAlignment = xlCenter
Exit Sub

Fehler: MsgBox "unerwarteter Fehler - Abbruch"
End Sub

.