Herbers Excel-Forum - das Archiv
Exceldateien auf Festplatte
Informationen und Beispiele zu den hier genannten Dialog-Elementen:
Betrifft: Exceldateien auf Festplatte
von: Marcel
Geschrieben am: 18.11.2003 15:10:09
Ich habe folgendes Makro übernommen. Funktioniert soweit ganz gut. Nur habe ich keine Diskette im Laufwerk, da bricht das Makro mit Fehlermeldung ab. Meine beiden Festplatten, die ich durchsuchen möchte, haben die Buchstaben C und E.
Wie kann ich das unten stehende Makro modifizieren?
Danke
Marcel
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
Betrifft: AW: Exceldateien auf Festplatte
von: Nepumuk
Geschrieben am: 18.11.2003 17:30:42
Hallo Rainer,
so geht's:
Option Explicit
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
If myDrv.IsReady Then
With myDrvList
myStr = "" & myDrv.DriveLetter & " - "
If myDrv.drivetype = 3 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 = True '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
End If
Next
Else
For Each myDrv In myDrvList
If myDrv.IsReady Then
With myDrvList
myStr = "" & myDrv.DriveLetter & " - "
If myDrv.drivetype = 3 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 = True '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
End If
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: Excel Code Jeanie
Gruß
Nepumuk
Betrifft: AW: Exceldateien auf Festplatte
von: Marcel
Geschrieben am: 19.11.2003 07:08:31
Sorry, habe das Makro von Rainer bekommen und beim Kopieren seinen Namen mitgenommen.
Vielen Dank.
Gruß Marcel
Betrifft: AW: Exceldateien auf Festplatte
von: Marcel
Geschrieben am: 19.11.2003 07:08:38
Sorry, habe das Makro von Rainer bekommen und beim Kopieren seinen Namen mitgenommen.
Vielen Dank.
Gruß Marcel
