AW: Dateien auslesen.
26.09.2005 11:58:40
Riko
Anbei das Macro, welches schon eimal hier erstellt wurde:
Füge dieses einfach in ein neues Modul ein:
Option Explicit
Sub Unterverzeichnis()
'* 07.10.04, 31.07.05; 02.08.05 *
'* erstellt von Ramses Rainer *
'* Anpassungen von Hajo *
'* <a href="http://home.media-n.de/ziplies/">http://home.media-n.de/ziplies/</a> *
Dim Dateiform As String
Dim J As Integer
Dim Bereich As Range
Dim Dateiname As String
J = 1
Dim I As Long, TotFiles As Long
Dim Suchpfad As String
Dim OldStatus As Variant
Dim L As Integer
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", "*.*")
If Dateiform = "" Then Exit Sub
Application.ScreenUpdating = True
OldStatus = Application.StatusBar
' neue Tabelle anlegen
Sheets.Add After:=Worksheets(Worksheets.Count)
With Application.FileSearch
.LookIn = Suchpfad ' Suchverzeichnis
.SearchSubFolders = True ' auch in Unterorndner Suchen
.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
' feststellen des Verzeichnisses
For L = Len(.FoundFiles(I)) To 1 Step -1
If Mid(.FoundFiles(I), L, 1) = "\" Then Exit For
Next L
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
If J > 256 Then MsgBox "Es sind mehr als 256 Unterverzeichnisse": GoTo Ende
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 <> ""
' **** Ergänzung Hyperlink
ActiveSheet.Hyperlinks.Add Anchor:=Cells(Cells(Rows.Count, I).End(xlUp).Row + 1, I), _
Address:=Cells(1, I) & Dateiname, TextToDisplay:=Dateiname
Dateiname = Dir
Loop
Next I
End If
End With
Ende:
Application.StatusBar = OldStatus
Application.ScreenUpdating = True
End Sub