Aus Excel heraus per Makro Dateiinformationen ermitteln und in Tabelle speichern

Option Explicit
Dim fso As Object 'FileSystemObject  
'------------------------------------------  
Sub FillMe()
    On Error GoTo fail
      Set fso = CreateObject("Scripting.FilesystemObject") 'New FileSystemObject  
      
      Dim sFiles() As String  'Speicher für die Dateinamen  
      Dim sSize() As String   'Speicher für die Dateigrößen  
      
      'Init der Speicher auf 0  
      ReDim sFiles(0)
      ReDim sSize(0)
     
      Dim sucheIn As String
      Dim sucheNach As String
      
      sucheIn = "C:\temp\" 'Order in dem nach Dateien gesucht werden soll  

      sucheNach = "*.*"    'Dateityp nachdem gesucht werden soll  
      '(abc*.* wird nicht Funktionieren!)  
      '*.*, *.doc oder *.blabla  
      Call SucheHier(sucheIn, sucheNach, sFiles(), sSize(), True)
      
        
        
        If UBound(sFiles()) - 1 < 0 Then
            'Nix gefunden  
            Exit Sub
        Else
            'Damit Excel nicht flackert ....  
            Application.ScreenUpdating = False
            Dim owb As Workbook
            Dim oSheet As Worksheet
            Dim i As Integer
            
            'Neues Workbook anlegen (damit man nix überschreibt)  
            Set owb = Application.Workbooks.Add
            'ein neues sheet hinzufügen  
            Set oSheet = owb.Sheets.Add
               'Spalte 2 selektieren damit diese Spalte als Text definiert wird  
                Columns("B:B").Select  
                Selection.NumberFormat = "@"  
                'Selektion aufheben  
                Range("A1").Select  
            'Für alle gefundenen Dateien in die Zelle i des Sheets den Dateinamen eintragen.  
            For i = 0 To UBound(sFiles()) - 1
                oSheet.Cells(i + 1, 1) = sFiles(i)      'DateiName  
                oSheet.Cells(i + 1, 2).Value = sSize(i) 'KBytes  
            Next i
            Application.ScreenUpdating = True 'Aktualisierung wieder aktivieren  
        End If
        
fail:
Application.ScreenUpdating = True 'Aktualisierung wieder aktivieren  
End Sub
'-----------------------------  
Sub SucheHier(ByVal sFolder As String, ByVal sFiletype As String, ByRef oRetFiles() As String, ByRef oRetSize() As String, Optional ByVal SubFolder As Boolean = False)
'sFolder = sucheIn  
'sFileType = sucheNach  
'oRetFiles() = String Array für die gefundenen Dateien  
'oRetSize() = String Array für die Dateigrößen-information  
'SubFolder = Boolean Flag (default = False = keine Unterverzeichnisse durchsuchen)  
'-----------------------------  

On Error GoTo fail 'bei einem Fehler gehts bei fail: weiter  
Dim oFolder As Object 'Folder  
Dim oFile As Object 'File  

       'Für jeden file in dem Folder  
        For Each oFile In fso.GetFolder(sFolder).Files
            'nur wenn der dateiname = *.blabla oder *.* (alle) ist.  
            If LCase("*." & fso.GetExtensionName(oFile.ShortName)) = LCase(sFiletype) Or sFiletype = "*.*" Then  
               'Rückgabe Array vergrößern  
                ReDim Preserve oRetFiles(UBound(oRetFiles()) + 1)
                ReDim Preserve oRetSize(UBound(oRetSize()) + 1)
                     'Hinzufügen ins Array  
                      oRetFiles(UBound(oRetFiles()) - 1) = oFile.ShortPath
                      oRetSize(UBound(oRetSize()) - 1) = oFile.Size / 1024
            End If
        Next
        
       'Falls der aktuelle Ordner weitere Ordner beinhaltet ( ....subFolders.Count > 0)  
       'und der Parameter SubFolder = True übergeben worden ist ab in einer Rekursion bis kein Ordner mehr vorhanden ist  
        If SubFolder = True And fso.GetFolder(sFolder).SubFolders.Count > 0 Then
           For Each oFolder In fso.GetFolder(sFolder).SubFolders
              'Rekursion  
               Call SucheHier(oFolder.Path, sFiletype, oRetFiles, oRetSize, SubFolder)
           Next oFolder
        End If

fail:
'Falls mal was daneben geht  
End Sub