Wenn möglich Makro ändern !!

Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare 

Function CoTaskMemFree Lib "ole32" (ByVal hMem As Long) As Long
Private Declare 

Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpStr1 As String, ByVal lpStr2 As  _
String) As Long
Private Declare 

Function SHGetPathFromIDList Lib "shell32" (ByVal pList As Long, ByVal lpBuffer As String) As    _
_
_
Long
Private Declare 

Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassname As String, ByVal  _
lpWindowName As String) As Long
Private Type BrowseInfo
hwnd As Long
Root As Long
DisplayName As Long
Title As Long
Flags As Long
FName As Long
lParam As Long
Image As Long
End Type


Sub Verzeichnis()
Dim strName As String, strFolder As String, strAntwort As String
Dim strRow As Long, strFiles As Long
strFolder = GetAOrdner
If strFolder = "" Then Exit Sub
strAntwort = InputBox("Gebe den Dateityp an, der gesucht werden soll !" & String(5, 10) & _
"Hinweis für die Eingabe = *.* - *.xls - *.txt  usw.", "Dateierweiterung")
If strAntwort = "" Then Exit Sub
Application.ScreenUpdating = False
'Sheets.Add After:=Worksheets(Worksheets.Count) 'Tabelle neuanlegen
With Columns(1).ClearContents
End With
With Application.FileSearch   ' 0 Then
strFiles = .FoundFiles.Count
For strRow = 1 To .FoundFiles.Count    ' Schleife über alle gefundenen Dateien
'           Dateiname abtrennen ab XP
strName = Mid(.FoundFiles(strRow), InStrRev(.FoundFiles(strRow), "\") + 1)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(strRow, 1), _
Address:=.FoundFiles(strRow), TextToDisplay:=strName           ' Hyperlink
Cells(strRow, 1) = Left$(strName, Len(strName) - 0)                ' 4 ohne  _
Erweiterung
'           Cells(strRow, 2) = FileLen(.FoundFiles(strRow))                       ' Dateigröße
'           Cells(strRow, 3) = FileDateTime(.FoundFiles(strRow))               ' Dateidatum
Next strRow
End If
End With
Columns("A:C").Columns.AutoFit              ' optimale Breite für Spalte A:C
Application.ScreenUpdating = True
End Sub




Function GetAOrdner() As String
Dim xl As BrowseInfo, IDList As Long, RVal As Long, FolderName As String
With xl
.hwnd = FindWindow("xlmain", vbNullString)
.Title = lstrcat("Verzeichnis auswählen", "")
.Flags = 1
End With
IDList = SHBrowseForFolder(xl)
If IDList  0 Then
FolderName = Space(256)
RVal = SHGetPathFromIDList(IDList, FolderName)
CoTaskMemFree (IDList)
FolderName = Trim(FolderName)
FolderName = Left(FolderName, Len(FolderName) - 1)
End If
GetAOrdner = FolderName
End Function