AW: Lösung bereits gefunden
05.05.2021 09:40:36
Peter
Hallo Franz,
ich bitte um Entschuldigung.
Die Lösung von mir:
Option Explicit
'eingebaut in Workbook_Open
Sub Unterordner_auflisten()
Dim wb As Workbook
Dim ws As Worksheet
Dim loLetzte As Long
Dim x As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Worddaten")
'Anfang SpalteH Inhalte löschen
loLetzte = ws.Cells(ws.Rows.Count, 32).End(xlUp).Row
If ws.Range("AF2") > "" Then
ws.Range("AF2:AF" & loLetzte).ClearContents
End If
'Ende SpalteH Inhalte löschen
x = ws.Range("B68") 'Pfad dieses Grundordners
Call ShowFolderList(x)
End Sub
Function ShowFolderList(folderspec)
Dim wb As Workbook
Dim ws As Worksheet
Dim fso, f, f1, s, Sf, n
Set wb = ThisWorkbook
Set ws = wb.Sheets("Worddaten")
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(folderspec)
Set Sf = f.SubFolders
n = 2 'ab 2. Zeile 'n = 1 'ab 1. Zeile
For Each f1 In Sf
s = f1.Name
If Left(s, 1) = "0" Then 'nur die Unterordner auflisten, die mit "0" (Null) beginnen
ws.Cells(n, 32).Value = s
n = n + 1
End If
Next
ShowFolderList = s
End Function
Wünsche noch einen schönen Tag.
Gruss
Peter