Moin!
Ist nicht ganz profan.
Das Makro in der Mappe erzeugt ein neues Tabellenblatt, in der alle Dateien eines ausgewählten Ordner (incl. optionalen Unterordnern) per Hyperlink aufgelistet werden.
Wer die Datei nicht öffnen will, sieht hier den Code:
Modul Modul1Option Explicit
Public x()
Public i#
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, oFile
Sub MainExtractData()
Dim NewSht As Worksheet
Dim MainFolderName$, k#
Dim SubFolders As Boolean
Redim x(1 To 2 ^ 20, 1 To 3)
Set objShell = CreateObject("Shell.Application")
Application.ScreenUpdating = False
PfadName:
MainFolderName = BrowseForFolder()
If MainFolderName = "" Then _
If MsgBox("Willst Du wirklich abbrechen?", vbYesNo + vbQuestion) = vbNo Then _
GoTo PfadName Else Exit Sub
SubFolders = MsgBox("Unterordner einbeziehen?", vbYesNo + vbQuestion) = vbYes
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
x(1, 1) = "FullName"
x(1, 2) = "FileName"
x(1, 3) = "Hyperlink"
i = 1
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(MainFolderName)
For Each oFile In oFolder.Files
Set objFolder = objShell.Namespace(oFolder.Path)
Set objFolderItem = objFolder.ParseName(oFile.Name)
i = i + 1
If i > 66530 Then 'maximale Anzahl an Hyperlinks pro Blatt!
MsgBox "Abbruch! max. Anzahl Hyperlinks in " & ActiveSheet.Name & " erreicht!"
GoTo Formatieren
End If
Application.StatusBar = "Datei " & i - 1 & " wird bearbeitet …"
DoEvents
x(i, 1) = oFolder.Path & "\" & oFile.Name
x(i, 2) = oFile.Name
Next
If SubFolders Then Call RecursiveFolder(oFolder)
Formatieren:
Range("A1:C" & i) = x
For k = 2 To i
ActiveSheet.Hyperlinks.Add _
Anchor:=Cells(k, 3), _
Address:=Cells(k, 1).Text, _
ScreenTip:="Link zu: " & Cells(k, 1).Text, _
TextToDisplay:=Cells(k, 2).Text
Next
Range("A:C").EntireColumn.AutoFit
Columns(2).Hidden = True
Range("1:1").Font.Bold = True
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Application.GoTo Range("A1")
Set FSO = Nothing
Set objShell = Nothing
Set oFolder = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set oFile = Nothing
Application.StatusBar = ""
Application.ScreenUpdating = True
End Sub
Sub RecursiveFolder(xFolder)
Dim SubFld
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
Set objFolder = objShell.Namespace(SubFld.Path)
For Each oFile In SubFld.Files
Set objFolder = objShell.Namespace(oFolder.Path)
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(oFile.Name)
i = i + 1
Application.StatusBar = "Datei " & i - 1 & " wird bearbeitet …"
DoEvents
x(i, 1) = SubFld.Path & "\" & oFile.Name
x(i, 2) = oFile.Name
End If
Next
Call RecursiveFolder(SubFld)
Next
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Ordner wählen", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0
Gruß Ralf
