alle Exceldateien der Festlatte auflisten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo

Das Makro schreibt alle Files in das aktuelle Tabellenblatt.
Hast du mehr als 65536 Files musst du Bescheid sagen ;-),... sonst kommt ein Laufzeitfehler.
Optional besteht noch die Möglichkeit, den Eintrag auch gleich mit einem Hyperlink zu versehen.

Sub Write_All_ExcelFiles_in_worksheet()
'by Ramses
Dim myFSO As Object
Dim myDrvList, myDrv, mySpace
Dim Dateiform As String, myStr As String
Dim geffile As String
Dim i As Long, totFiles As Long, chkHype As Integer
Dim oldStatus As Variant
Set myFSO = CreateObject("Scripting.Filesystemobject")
Set myDrvList = myFSO.drives
Application.ScreenUpdating = True
oldStatus = Application.StatusBar
On Error GoTo myErrHandler
Dateiform = InputBox("Geben Sie den Dateityp an der gesucht werden soll", "Dateierweiterung", "*.xls")
If Dateiform = "" Then
    Application.ScreenUpdating = True
    Exit Sub
End If
chkHype = MsgBox("Gefundene Dateien als Hyperlink anlegen", vbYesNo + vbInformation, "Hperlinks erstellen")
If chkHype = vbYes Then
    For Each myDrv In myDrvList
        With myDrvList
            myStr = "" & myDrv.DriveLetter & " - "
            If myDrv.drivetype = remote Then
                myStr = myStr & myDrv.sharename & ": "
            Else
                myStr = myStr & myDrv.volumename & ": "
            End If
            Set mySpace = myFSO.getdrive(myFSO.getdrivename(myDrv.DriveLetter & ":"))
        End With
        With Application.FileSearch
            .LookIn = mySpace
            .SearchSubFolders = False 'True für Suche in allen Unterverzeichnissen!!
            .Filename = Dateiform
            If .Execute() > 0 Then
                totFiles = .FoundFiles.Count
                Application.StatusBar = "Total " & totFiles & " in " & mySpace & ": gefunden "
                For i = 1 To .FoundFiles.Count
                    geffile = .FoundFiles(i)
                    'In Tabelle eintragen
                    Cells([A65536].End(xlUp).Row + 1, 1) = geffile
                    ActiveSheet.Hyperlinks.Add Anchor:=Cells([A65536].End(xlUp).Row, 1), Address:=geffile _
                        , TextToDisplay:=geffile
                Next i
            End If
        End With
    Next
Else
    For Each myDrv In myDrvList
        With myDrvList
            myStr = "" & myDrv.DriveLetter & " - "
            If myDrv.drivetype = remote Then
                myStr = myStr & myDrv.sharename & ": "
            Else
                myStr = myStr & myDrv.volumename & ": "
            End If
            Set mySpace = myFSO.getdrive(myFSO.getdrivename(myDrv.DriveLetter & ":"))
        End With
        With Application.FileSearch
            .LookIn = mySpace
            .SearchSubFolders = False 'True für Suche in allen Unterverzeichnissen!!
            .Filename = Dateiform
            If .Execute() > 0 Then
                totFiles = .FoundFiles.Count
                Application.StatusBar = "Total " & totFiles & " in " & mySpace & ": gefunden "
                For i = 1 To .FoundFiles.Count
                    geffile = .FoundFiles(i)
                    'In Tabelle eintragen
                    Cells([A65536].End(xlUp).Row + 1, 1) = geffile
                Next i
            End If
        End With
    Next
End If

ErrEntry:
Application.StatusBar = oldStatus
Application.ScreenUpdating = True
MyExit:
Close #1
Exit Sub

myErrHandler:
Select Case Err
    Case 71
        myStr = myStr & "Datenträger nicht bereit"
End Select
Resume ErrEntry
End Sub

Code eingefügt mit Syntaxhighlighter 1.16

Gruss Rainer

Beliebteste Forumthreads (12 Monate)

alle Exceldateien der Festlatte auflisten

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread