wieoderwas
Nov 21, 2023, updated at 10:59:20 (UTC)
view1469
view13
0
Goto Top

Excel Dateien aus Ordner anzeigen lassen

GermansolvedQuestionVB for ApplicationsMicrosoft OfficeXMLBatch, Shell
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?
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 71222426787

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

Printed on: April 27, 2024 at 11:04 o'clock

13 Comments
Latest comment
Goto Top
Member: Kraemer
Kraemer Nov 21, 2023 at 11:15:57 (UTC)
Goto Top
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ß
Mitglied: 8030021182
8030021182 Nov 21, 2023 updated at 12:35:43 (UTC)
Goto Top
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
Member: wieoderwas
wieoderwas Nov 21, 2023 updated at 12:09:26 (UTC)
Goto Top
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
Mitglied: 8030021182
8030021182 Nov 21, 2023 updated at 12:09:30 (UTC)
Goto Top
Siehe oben, da wird das schon gemacht Zeile 9 Array der Extensions definiert und Zeile 29 die Extension der Datei geprüft.
Member: wieoderwas
wieoderwas Nov 21, 2023 at 12:10:33 (UTC)
Goto Top
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?
Mitglied: 8030021182
8030021182 Nov 21, 2023 at 12:13:07 (UTC)
Goto Top
Ist doch schon komplett.
Member: wieoderwas
wieoderwas Nov 21, 2023 at 12:15:19 (UTC)
Goto Top
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?
Mitglied: 8030021182
8030021182 Nov 21, 2023 updated at 12:19:25 (UTC)
Goto Top
Aber mein abgeändertes oben :-P. Ist doch alles schön mit Kommentaren versehen, schon wieder Freitag 🙈?!
Member: wieoderwas
wieoderwas Nov 21, 2023 at 12:21:18 (UTC)
Goto Top
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?
Mitglied: 8030021182
8030021182 Nov 21, 2023 updated at 12:29:47 (UTC)
Goto Top
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
' ...

🖖
Member: wieoderwas
wieoderwas Nov 21, 2023 at 12:28:11 (UTC)
Goto Top
funktioniert nicht face-sad
Mitglied: 8030021182
8030021182 Nov 21, 2023 at 12:30:00 (UTC)
Goto Top
Klappt hier einwandfrei ...
Member: wieoderwas
wieoderwas Nov 21, 2023 at 12:30:47 (UTC)
Goto Top
Ja habe es nun. Vielen Dank.
Zu deinen blöden Kommentare sage ich nun mal nichts.

Schönen Tag dir noch.
GermansolvedQuestionVB for ApplicationsMicrosoft OfficeXMLBatch, Shell