Re: dir verz. und files auflisten lassen
13.12.2002 17:17:07
andreas e
hallo, hier ein ansatz //verzeichnisstruktur auslesen//
sub List_Files_in_all_folder2()
' jedes Unterverzeichnis in eine Spalte
' ergänzt
' einschl unterordner von Ramses Rainer
Dim Dateiform As String
Dim Verzeichnis As String
Dim J As Integer
Dim K As Long
Dim Bereich As Range
Dim Dateiname As String
J = 1: K = 2
Dim I As Long, TotFiles As Long
Dim gefFile As String, dname As String
Dim Suchpfad As String, suchbegriff As String
Dim OldStatus As Variant
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad definieren", Application.DefaultFilePath)
If Suchpfad = "" Then Exit Sub
Dateiform = InputBox("Geben Sie den Dateityp an der gesucht werden soll", "Dateierweiterung", "*.xls")
If Dateiform = "" Then Exit Sub
Application.ScreenUpdating = True
OldStatus = Application.StatusBar
With Application.FileSearch
.LookIn = Suchpfad
.SearchSubFolders = True
' .SearchSubFolders = False
.Filename = Dateiform
If .Execute() > 0 Then
TotFiles = .FoundFiles.Count
Application.StatusBar = "Total " & TotFiles & " gefunden"
For I = 1 To .FoundFiles.Count
' ergänzt für Unterverzeichnis
' festellen aller Unterverzeichnisse und in Zeile 1 schreiben
Dim L As Integer
For L = Len(.FoundFiles(I)) To 1 Step -1
If Mid(.FoundFiles(I), L, 1) = "\" Then Exit For
Next L
If Verzeichnis = "" Then
Verzeichnis = Mid(.FoundFiles(I), 1, L)
Else
If Mid(.FoundFiles(I), 1, L) <> Verzeichnis Then
Verzeichnis = Mid(.FoundFiles(I), 1, L)
K = 2
End If
End If
Set Bereich = ActiveSheet.Range("A1:IV256").Find(Mid(.FoundFiles(I), 1, L), lookat:=xlWhole)
If Bereich Is Nothing Then
Cells(1, J) = Mid(.FoundFiles(I), 1, L)
J = J + 1
End If
Next I
' Dateienfeststellen
For I = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
Dateiname = Dir(Cells(1, I) & Dateiform)
Do While Dateiname <> ""
Cells(Cells(Rows.Count, I).End(xlUp).Row + 1, I).Value = Dateiname
K = K + 1
Dateiname = Dir
Loop
Next I
' ******
End If
End With
Application.StatusBar = OldStatus
Application.ScreenUpdating = True
End Sub
gruß
andreas e
http://www.skripteundaufgaben.de viele kostenlose Downloads und Lösungsansätze zu EXCEL und mehr