Excel Dateien aus Ordner anzeigen lassen

Hallo zusammen,

leider habe ich auch durch die google Suche nichts passendes gefunden.

Ich möchte alle Exceldateien inklusive Unterordnern in eine Exceldatei mit Pfad und Name abspeichern lassen.
Hat dafür jemand ein passenden VBA Script?

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 71222426787

Url: https://administrator.de/contentid/71222426787

Ausgedruckt am: 25.11.2024 um 08:11 Uhr

13 Kommentare

Neuester Kommentar

Hallo zusammen,

Moin,

leider habe ich auch durch die google Suche nichts passendes gefunden.

das sind die passenden Suchbegriffe für google.de:

excel vba dateien inklusive unterordner

Gruß

Hi.

leider habe ich auch durch die google Suche nichts passendes gefunden.

Wieso so weit weg schweifen, liegt doch alles hier.

Hat dafür jemand ein passenden VBA Script?

...

Dim fso As Object
Sub ImportData()
    Dim col As New Collection, file As Variant, wb As Workbook, intRow As Long
    'Ordner der die Dateien enthält    
    Const FOLDER = "C:\MeineDateien"    
    'Filesystemobject    
    Set fso = CreateObject("Scripting.FileSystemObject")    
    'alle Excel-Dateien rekursiv listen    
    getAllFiles fso.GetFolder(FOLDER), True, Array("xlsx", "xls"), col    
    'Screenupdates und eventuelle Dialoge für Batchbetrieb unterdrücken  
    Application.ScreenUpdating = False
    
    With Sheets(1)
        .UsedRange.Clear
        ' Header schreiben  
        .Range("A1:C1").Value = Array("Ordner", "Dateiname", "Erstelldatum")  
        ' Startzeile  
        intRow = 2
        ' Dateinamen untereinander in Spalte A schreiben  
        For Each file In col
           .Cells(intRow,"A").Resize(1,3).Value = file  
           ' Hyperlink einfügen  
           .Hyperlinks.Add Anchor:=.Cells(intRow, "B"), Address:=(file(0) & file(1))  
           intRow = intRow + 1
        Next
    End With
    'Screenupdates und Dialoge wieder einschalten    
    Application.ScreenUpdating = True
End Sub

Sub getAllFiles(ByVal fldr As Object, boolRecursion As Boolean, arrFileExtensions As Variant, ByRef col As Collection)
    For Each file In fldr.Files
        For i = 0 To UBound(arrFileExtensions)
            If LCase(arrFileExtensions(i)) = LCase(fso.GetExtensionName(file.Path)) Then
                col.Add Array(file.ParentFolder, file.Name, file.DateCreated)
                Exit For
            End If
        Next
    Next
    If boolRecursion Then
        For Each subFolder In fldr.SubFolders
            getAllFiles subFolder, True, arrFileExtensions, col
        Next
    End If
End Sub

Gruß Katrin

Ich habe diesen Code mit Hilfes eines Videos nachgebaut. Es funktioniert sehr gut. Kann mir einer sagen anwelcher Stelle ich nun es eingrenzen könnte das nur xls, xlsx usw. gesucht werden?

Es müsste ja was mit Instr(1, oder sowas sein.

Option Explicit

'Verweis auf die Microsoft Scripting Runtime Bibliothek  

Sub AlleDateienAuslesen()

'Variablen dimensionieren  
Dim Ordner As Variant
Dim Pfad As String

'Benutzer Ordner auswählen lassen  
Set Ordner = Application.FileDialog(msoFileDialogFolderPicker)

'Prüfen, ob Benutzer einen Ordner ausgewählt hat  
If Ordner.Show = False Then Exit Sub

'Pfad definieren  
Pfad = Ordner.SelectedItems(1)

'Neues Tabellenblatt erstellen  
Worksheets.Add

'Überschriften eintragen  
Range("A1:C1").Value = Array("Datei", "Ordner", "Erstellungsdatum")  

'Dateien des Ordners auslesen  
Call DateienAuslesen(Pfad)

'Dateien der Unterordners auslesen  
Call UnterordnerAuslesen(Pfad)


'Spaltenbreite automatisch anpassen  
Columns("A:C").AutoFit  



End Sub

Sub UnterordnerAuslesen(Pfad As String)

'Variablen dimensionieren  
Dim fso As New FileSystemObject
Dim Unterordner As Folder

'Schleife über alle Unterordner im ordner  
For Each Unterordner In fso.GetFolder(Pfad).SubFolders

'Dateien des Unterordners auslesen  
    Call DateienAuslesen(Unterordner.Path)
    
'Prozedur Unterordner wieder aufrufen  
Call UnterordnerAuslesen(Unterordner.Path)
    
Next Unterordner

End Sub




Sub DateienAuslesen(Pfad As String)

'Variablen dimensionieren  
Dim fso As New FileSystemObject
Dim Datei As File
Dim LetzteZeile As Long

    'Schleife über alle Dateien im Ordner  
    For Each Datei In fso.GetFolder(Pfad).Files

    'Letzte Zeile herausfinden  
    LetzteZeile = Cells(Rows.Count, 1).End(xlUp).Row + 1


    'Ergebnisse ins Tabellenblatt schreiben  
    ActiveSheet.Hyperlinks.Add anchor:=Cells(LetzteZeile, 1), Address:=Datei.Path, TextToDisplay:=Datei.Name
    Cells(LetzteZeile, 2).Value = Datei.ParentFolder
    Cells(LetzteZeile, 3).Value = Datei.DateCreated
    

Next Datei

End Sub

Siehe oben, da wird das schon gemacht Zeile 9 Array der Extensions definiert und Zeile 29 die Extension der Datei geprüft.

Zitat von @8030021182:

Siehe oben, da wird das schon gemacht Zeile 9 Array der Extensions definiert und Zeile 29 die Extension der Datei geprüft.

Wo müsste ich dieses einbauen?

Ist doch schon komplett.

Zitat von @8030021182:

Ist doch schon komplett.

Wie meinst du das? In dem Script was ich gepostet habe kann ich noch nicht nach Excel Listen filtern?

Aber mein abgeändertes oben :-P. Ist doch alles schön mit Kommentaren versehen, schon wieder Freitag 🙈?!

Aber bei deinem Script hat man keine Verklinkung drin.
Kannst du mirsagen was ich bei mir einbauen müsste damit ich wie in deinem Script nur die xlsx und xls suchen kann?

Aber bei deinem Script hat man keine Verklinkung drin.

Pillepalle mit Hyperlink, ist hinzugefügt.
War ja klar Copy n Paster ...

' ...  
' ..  
For Each Datei In fso.GetFolder(Pfad).Files
    dim ext as string
    ext = LCase(fso.GetExtensionName(Datei.Name))
    if ext = "xlsx" or ext = "xls" then  
        'Letzte Zeile herausfinden    
        LetzteZeile = Cells(Rows.Count, 1).End(xlUp).Row + 1

        'Ergebnisse ins Tabellenblatt schreiben    
        ActiveSheet.Hyperlinks.Add anchor:=Cells(LetzteZeile, 1), Address:=Datei.Path, TextToDisplay:=Datei.Name
        Cells(LetzteZeile, 2).Value = Datei.ParentFolder
        Cells(LetzteZeile, 3).Value = Datei.DateCreated
    End if

Next Datei
' ...  

🖖