Quelle: https://www.herber.de/mailing/072499h.htm
Ich bekomme aber Laufzeitfehler 445. Objekt unterstützt diese Aktion nicht.
Woran kann das liegen? Benutze Excel 2007
Sub DateiListe()
Dim wks As Worksheet
Dim iRow As Integer, iCounter As Integer, iRowT As Integer
Application.ScreenUpdating = False
Set wks = ActiveSheet
Workbooks.Add 1
iRow = 1
Do Until IsEmpty(wks.Cells(iRow, 1))
Cells(1, iRow).Value = wks.Cells(iRow, 1).Value
iRowT = 1
With Application.FileSearch
.NewSearch
.LookIn = wks.Cells(iRow, 1).Value
.Execute
For iCounter = 1 To .FoundFiles.Count
iRowT = iRowT + 1
Cells(iRowT, iRow).Value = _
.FoundFiles(iCounter)
Next iCounter
End With
iRow = iRow + 1
Loop
Rows(1).Font.Bold = True
Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Sub DateiListe()
Dim wks As Worksheet
Dim iRow As Integer, iCounter As Integer, iRowT As Integer
Dim Fso, Ordner, varDatei
Dim DateiName As String
Set Fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
Set wks = ActiveSheet
Workbooks.Add 1
iRow = 1
Do Until IsEmpty(wks.Cells(iRow, 1))
Cells(1, iRow).Value = wks.Cells(iRow, 1).Value
iRowT = 1
Set Ordner = Fso.getfolder(wks.Cells(iRow, 1).Value)
For Each varDatei In Ordner.Files
iRowT = iRowT + 1
DateiName = _
Right$(varDatei, Len(varDatei) - InStrRev(varDatei, "\"))
Cells(iRowT, iRow).Value = DateiName
Next varDatei
iRow = iRow + 1
Loop
Rows(1).Font.Bold = True
Columns.AutoFit
Application.ScreenUpdating = True
Set Fso = Nothing
End Sub
Gruß Tino
Option Explicit
Sub DateiListe()
Dim wks As Worksheet
Dim iRow As Integer, iCounter As Integer, iRowT As Integer
Dim Fso, Ordner, varDatei
Dim DateiName As String, strPfad As String
Set Fso = CreateObject("Scripting.FileSystemObject")
strPfad = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
Application.ScreenUpdating = False
Set wks = ActiveSheet
Workbooks.Add 1
iRow = 1
Do Until IsEmpty(wks.Cells(iRow, 1))
Cells(1, iRow).Value = wks.Cells(iRow, 1).Value
iRowT = 1
Set Ordner = Fso.getfolder(strPfad & wks.Cells(iRow, 1).Value)
For Each varDatei In Ordner.Files
iRowT = iRowT + 1
DateiName = _
Right$(varDatei, Len(varDatei) - InStrRev(varDatei, "\"))
Cells(iRowT, iRow).Value = DateiName
Next varDatei
iRow = iRow + 1
Loop
Rows(1).Font.Bold = True
Columns.AutoFit
Application.ScreenUpdating = True
Set Fso = Nothing
End Sub
Gruß Tino