oder auch so :-)

Option Explicit

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
 
Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Sub GetAllFiles()
    Dim Msg As String
    Dim Directory As String
    Msg = "Select the folder for the recursive directory listing."
    Directory = GetDirectory(Msg)
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
    Cells.ClearContents
    Call RecursiveDir(Directory)
End Sub

Public Sub RecursiveDir(ByVal CurrDir As String)
    Dim Dirs() As String
    Dim NumDirs As Long
    Dim FileName As String
    Dim PathAndName As String
    Dim i As Long

'   Make sure path ends in backslash
    If Right(CurrDir, 1) <> "\" Then CurrDir = CurrDir & "\"

'   Put column headings on active sheet
    Cells(1, 1) = "Path"
    Cells(1, 2) = "Filename"
    Cells(1, 3) = "Size"
    Cells(1, 4) = "Date/Time"
    Range("A1:D1").Font.Bold = True
   
'   Get files
    FileName = Dir(CurrDir & "*.*", vbDirectory)
    Do While Len(FileName) <> 0
      If Left(FileName, 1) <> "." Then 'Current dir
        PathAndName = CurrDir & FileName
        If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
          'store found directories
           ReDim Preserve Dirs(0 To NumDirs) As String
           Dirs(NumDirs) = PathAndName
           NumDirs = NumDirs + 1
        Else
          'Write the path and file to the sheet
          Cells(WorksheetFunction.CountA(Range("A:A")) + 1, 1) = CurrDir
          Cells(WorksheetFunction.CountA(Range("B:B")) + 1, 2) = FileName
          Cells(WorksheetFunction.CountA(Range("C:C")) + 1, 3) = FileLen(PathAndName)
          Cells(WorksheetFunction.CountA(Range("D:D")) + 1, 4) = FileDateTime(PathAndName)
        End If
    End If
        FileName = Dir()
    Loop
    ' Process the found directories, recursively
    For i = 0 To NumDirs - 1
        RecursiveDir Dirs(i)
    Next i
End Sub

Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

' Root folder = Desktop
    bInfo.pidlRoot = 0&

' Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
  End If

' Type of directory to return
    bInfo.ulFlags = &H1

' Display the dialog
    x = SHBrowseForFolder(bInfo)

' Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
  End If
End Function