AW: FileSearch-Problem unter XP
24.09.2003 09:34:06
Hajo_Zi
Hallo Marco
das ist mir aber neu das es nich Funktionieren soll. Folgenden Makro läuft bei mir Fehlerfrei.
Option Explicit
Sub List_Files_in_all_folder2()
' jedes Unterverzeichnis in eine Spalte ergänzt
' Original für 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
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
With Application.FileSearch
.LookIn = Suchpfad
' auch in Unterorndner Suchen
.SearchSubFolders = True
.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 <> ""
Cells(Cells(Rows.Count, I).End(xlUp).Row + 1, I).Value = Dateiname
K = K + 1
Dateiname = Dir
Loop
Next I
End If
End With
Ende:
Application.StatusBar = OldStatus
Application.ScreenUpdating = True
End Sub
Falls Code vorhanden wurde dieser getestet unter Betriebssystem XP Pro und Excel Version XP SBE.
Bitte kein Mail, Probleme sollen im Forum gelöst werden.
Microsoft MVP für Excel
Das Forum lebt auch von den Rückmeldungen.
Zurzeit gibt es wieder Probleme mit der E-Mail Benachrichtigung.
Ich bekomme Mails zu Beiträgen an denen ich nicht beteiligt bin und zusätzlich noch Mails zu meinen eigenen Beiträgen.
Das Problem mit den eigenen Benachrichtigung kann gelöst werden durch Lösche und Neuanmelden. Dieses möchte ich aber nicht jeden Tag machen.
Um dieses Problem erstmal zu beseitigen habe ich die automatische Mailbenachrichtigung abgeschaltet.
Aus diesem Grunde ist es dem Zufall überlassen ob auf Rückfragen Antworten von mir kommen.
http://home.media-n.de/ziplies/