Ordnerinhalt auslesen mit Hyperlink
20.02.2020 09:43:04
JanRe
ich habe diverse Ordner in verschiedenen Laufwerke und dazu folgendes VBA-Script,
welches die Inhalte mit gesamten Pfad ausgibt. Jedoch sind Pfadnamen lang und das Excelsheet wird schnell unübersichtlich.
Kann man das so machen, das nur die eigentliche Dateien/Dateinamen pro Ordner
als Hyperlinks angezeigt wird ?
Vielen Dank im Voraus!
Sub DateienMitHyperlinkAuflisten()
'##### Hauptordner bearbeiten #####
Dim FileSystem As Object
Dim Unterordner
Dim Datei
Dim Zeile As Long
Dim Spalte As Long
Dim Ordner
Set FileSystem = CreateObject("Scripting.FileSystemObject")
Spalte = 1
Zeile = 1
Ordner = "R:\CAD_Signatur"
If FileSystem.FolderExists(Ordner) Then
Set Ordner = FileSystem.Getfolder(Ordner)
With ActiveSheet.Cells(1, 1)
.Value = Ordner
.Font.Bold = True
.Interior.Color = RGB(220, 220, 220)
End With
For Each Datei In Ordner.Files
Zeile = Zeile + 1
' ActiveSheet.Cells(Zeile, Spalte).Value = Datei.Name
ActiveSheet.Hyperlinks.Add ActiveSheet.Cells(Zeile, Spalte), Datei
Next
ListOrdner Ordner, Zeile, 2
End If
End Sub
Sub ListOrdner(Ordner, Zeile, Spalte)
'##### Unterordner bearbeiten #####
Dim FileSystem As Object
Dim Unterordner
Dim Datei
Set FileSystem = CreateObject("Scripting.FileSystemObject")
If FileSystem.FolderExists(Ordner) Then
Set Ordner = FileSystem.Getfolder(Ordner)
For Each Unterordner In Ordner.Subfolders
Zeile = Zeile + 1
With ActiveSheet.Cells(Zeile, Spalte)
.Value = Unterordner.Name
.Font.Bold = True
.Interior.Color = RGB(220, 220, 220)
End With
For Each Datei In Unterordner.Files
Zeile = Zeile + 1
' ActiveSheet.Cells(Zeile, Spalte).Value = Datei.Name
ActiveSheet.Hyperlinks.Add ActiveSheet.Cells(Zeile, Spalte), Datei
Next
ListOrdner Unterordner, Zeile, Spalte + 1
Next
End If
ActiveSheet.UsedRange.EntireColumn.AutoFit
End Sub