Exceldateien auf Festplatte

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
Gruss Rainer