AW: Ordnernamen auflisten
18.11.2012 18:46:55
ransi
Hallo
Wer hat sowas schon einmal gemacht oder vielleicht ein derartiges Makro...?
Teste mal dies:
' **********************************************************************
' Modul: Tabelle2 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Dim zaehler As Long
Dim arr
Public Sub Aufruf()
Dim objShell As Object
Dim objFolder As Object
Dim objItem As Object
Redim arr(0)
Set objShell = CreateObject("Shell.Application")
With objShell
Set objFolder = .BrowseForFolder(0&, "Was soll ich machen?", 0)
End With
If Not objFolder Is Nothing Then
Set objItem = objFolder.Self
arr(0) = objItem.Path
Else: Exit Sub
End If
Schreiben objItem.Path, True 'True wenn die Unterordner auch wieder geschrieben werden sollen.
'Sonst False oder weglassen. Entspricht SearchSubfolders
Range("a1").Resize(UBound(arr)) = WorksheetFunction.Transpose(arr) 'ausgeben
zaehler = 0
End Sub
Public Sub Schreiben(Suchordner, Optional sbfolds As Boolean = False)
Dim fso As Object
Dim datei
Dim Unterordner
Set fso = CreateObject("Scripting.FileSystemObject")
Set datei = fso.getfolder(Suchordner)
On Error Resume Next
Select Case sbfolds
Case True
For Each Unterordner In datei.subfolders
zaehler = zaehler + 1
Redim Preserve arr(zaehler)
arr(zaehler) = Unterordner.Path
Schreiben Unterordner, True
Next
Case False
For Each Unterordner In datei.subfolders
zaehler = zaehler + 1
Redim Preserve arr(zaehler)
arr(zaehler) = Unterordner.Path
Next
End Select
Set fso = Nothing
Set datei = Nothing
End Sub
ransi