Hallo lieber Gemeinde,

vorab ich habe null Ahnung von VBA und hab mir jetzt alles son bisschen zusammen gesucht aber noch nicht mein Endgültiges Ergebniss erzielt. (Bisheriger Code folgt am Schluss)

Mit dem jetzigen CODE kann ich über ein Popup den Ordner auswählen und die Datein und Unterordner werden aufgelistet. Der Ort des Ordners ändert sich nicht nur der Inhalt. Ich möchte also gern

1. Beim öffnen der Excel-Datei soll sich das Verzeichnis automatisch aktualisieren.

2. Es soll immer wieder der gleiche Ordner aktualisiert werden.

so jetzt kommt warscheinlich der knifflige Teil

3. Die Datein haben alle das Bezeichnungsformat  "XX 123456 Text 01012015.pdf" ich würde gern das dieser Dateiname nun auf mehrere Spalten aufgeteilt wird. Das es so aussieht "XX | 12 | 34 | 56 | Text | 01012015"

4. Der Text soll dann auch noch nen Hyperlink zur Datei haben (das funktioniert im CODE schon ganz gut)

Zwei drei Sachen möchte ich eigentlich noch machen aber ich denke für den Anfang wäre ich schon mal froh wenn mir hierbei jemand helfen könnte.

Also haut in die Tasten freue mich schon über konstruktive Vorschläge ^^

CODE

Option Explicit
Dim lngColumn As Integer
Dim objFSO As Object
Dim objFOL As Object
Dim objFIL As Object
Dim objFO As Object
Dim objFU As Object
Dim lngRow As Long
Public Sub Ordner_Dateien_Auflisten()
Dim objShell As Object
Dim varDir As Variant
Dim strTMP As String
Set objShell = CreateObject("Shell.Application")
Set varDir = objShell.BrowseForFolder(0, "Folder", &H4000, 17)
Application.ScreenUpdating = False
On Error Resume Next
strTMP = varDir.Self.Path
On Error GoTo 0
On Error GoTo Fin
If strTMP <> "" And Left(strTMP, 2) <> "::" Then
If Right(strTMP, 1) <> "\" Then strTMP = strTMP & "\"
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
Tabelle1.Cells.Clear ' eventuell anpassen
lngRow = 0
lngColumn = 0
GetSubFolders_Files strTMP
Tabelle1.Columns.AutoFit
Fin:
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & " " & Err.Description
Set objShell = Nothing
Set varDir = Nothing
End Sub
Private Function GetSubFolders_Files(ByVal strPath As String) As String
Set objFO = objFSO.GetFolder(strPath)
Set objFU = objFO.SubFolders
With Tabelle1 ' eventuell anpassen
lngRow = lngRow + 1
lngColumn = lngColumn + 1
.Cells(lngRow, lngColumn).NumberFormat = "@"
.Cells(lngRow, lngColumn) = objFO.Name
.Hyperlinks.Add _
Anchor:=.Cells(lngRow, lngColumn), _
Address:=strPath, _
TextToDisplay:=.Cells(lngRow, lngColumn).Value
.Cells(lngRow, lngColumn).Font.Bold = True
.Cells(lngRow, lngColumn).Font.ColorIndex = 3
For Each objFIL In objFO.Files
lngRow = lngRow + 1
.Cells(lngRow, lngColumn + 1) = objFIL.Name
.Hyperlinks.Add _
Anchor:=.Cells(lngRow, lngColumn + 1), _
Address:=objFIL.Path, _
TextToDisplay:=.Cells(lngRow, lngColumn + 1).Value
Next objFIL
End With
For Each objFOL In objFU
GetSubFolders_Files objFOL.Path
Next objFOL
lngColumn = lngColumn - 1
End Function