Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
336to340
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
336to340
336to340
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Exceldateien auf Festplatte

Exceldateien auf Festplatte
18.11.2003 15:10:09
Marcel
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

                    

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Exceldateien auf Festplatte
18.11.2003 17:30:42
Nepumuk
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
Anzeige
AW: Exceldateien auf Festplatte
19.11.2003 07:08:31
Marcel
Sorry, habe das Makro von Rainer bekommen und beim Kopieren seinen Namen mitgenommen.
Vielen Dank.

Gruß Marcel
AW: Exceldateien auf Festplatte
19.11.2003 07:08:38
Marcel
Sorry, habe das Makro von Rainer bekommen und beim Kopieren seinen Namen mitgenommen.
Vielen Dank.

Gruß Marcel

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige