|
Ich hatte den Wunsch mir sämtliche Excel Beispiele, welche ich besitze, in einer Excel Tabelle auflisten zu lassen. Dafür habe ich mir folgendes Excel Makro geschrieben:
Sub Dateinmen_auflisten()
Dim x As Integer
Dim strGef As Long
Dim strPfad As String
strPfad = "c:\Excel\Excel\"
Application.ScreenUpdating = False
UsedRange.Clear
With Application.FileSearch
.LookIn = strPfad
.FileType = msoFileTypeExcelWorkbooks
.Execute
x = .FoundFiles.Count
For strGef = 1 To x
Cells(strGef, 1) = .FoundFiles(strGef)
Next
End With
Application.ScreenUpdating = True
End Sub
Da ich viele Excel Beispiele besitze und diese auch teilweise für Forumsarbeiten benötige, habe ich mir, damit es schneller geht, dieses Makro noch so umgebaut, dass Hyperlinks ins Tabellenblatt integriert werden. das ging mit recht wenig Aufwand. Das Makro sieht dann so aus:
Sub Dateinmen_auflisten()
Dim x As Integer
Dim strGef As Long
Dim strPfad As String
strPfad = "c:\Excel\Excel\"
Application.ScreenUpdating = False
UsedRange.Clear
With Application.FileSearch
.LookIn = strPfad
.FileType = msoFileTypeExcelWorkbooks
.Execute
x = .FoundFiles.Count
For strGef = 1 To x
ActiveSheet.Hyperlinks.Add Anchor:=Cells(strGef, 1), Address:= _
.FoundFiles(strGef), TextToDisplay:= _
.FoundFiles(strGef)
Next
End With
Application.ScreenUpdating = True
End Sub
Leider funktioniert dieses Makro nur bis Excel 2003. Ab der Excel Version 2007 gibt es nicht mehr den Befehl Application.Filesearch. Hier musste ich jetzt selber in einem Forum nachfragen, wie man jetzt vorgehen sollte. Die Version, welche ich jetzt nenne funktioniert nicht nur ab Version 2007, sondern auch mit Excel 2003:
Sub Dateinamen_auflisten()
Dim FSO As Object
Dim strPfad As String
Dim x As Integer
Dim strGef As Object
Application.ScreenUpdating = False
strPfad = "c:\Excel\Excel\"
ActiveSheet.UsedRange.Clear
Set FSO = CreateObject("Scripting.FilesystemObject")
For Each strGef In FSO.getfolder(strPfad).Files
Select Case LCase(FSO.getextensionname(strGef))
Case "xls", "xla", "xlsm", "xlsx"
x = x + 1
ActiveSheet.Hyperlinks.Add Anchor:=Cells(x, 1), Address:= _
strGef, TextToDisplay:=strGef.Name
End Select
Next
Application.ScreenUpdating = True
End Sub
|