Option Explicit Sub Test() 'Ersatz für Application.FileSearch entwickeln und testen Dim Pfad As String 'Startpfad Dim Daten As New Collection 'gesammelte Ergebinsse Dim Eintrag Pfad = ThisWorkbook.Path 'wenn dieses Programm unter Excel läuft 'Pfad = ActiveDocument.Path 'falls es unter Word laufen soll 'Mehrere Möglichkeiten für die Suche: Call FileList(Daten, Pfad) 'Alles im aktuellen Ordner 'Call FileList(Daten, Pfad, "*.xl*") 'Exceldateien im aktuellen Ordner 'Call FileList(Daten, "C:\Xxxxx\yyyy") 'Inhalt von Ordner C:\Xxxxx\yyyy 'Call FileList(Daten, Pfad & "\..", "*.xl*") 'Excel im übergeordneten Ordner If Daten.Count = 0 Then MsgBox ("In Ordner " & Pfad & " Nichts gefunden.") Exit Sub End If For Each Eintrag In Daten 'Testausgabe im Direktbereich (Funktionen: siehe voriger Abschnitt) Debug.Print Pfadname_von(Eintrag) & " " & Dateiname_von(Eintrag) 'hier könnten dann Ihre weiteren Befehle stehen '... '... Next Eintrag End Sub Sub FileList(Daten As Collection, Pfad As String, _ Optional Filter As String = "", _ Optional SubDIR As Boolean = False) 'Inhalt eines Ordners ermitteln 'Lösung mit dem Befehl Dir() ohne Rekursion ' 'Optionaler Parameter Filter: z. B. "*.xl*" für Excel-Dateien ' oder "*.doc*" für Word-Dateien ' ohne diesen Parameter werden auch Ordnernamen mit ausgegeben ' 'Optionaler Parameter SubDIR: True : mit Suche von Unterordnern ' (noch nicht realisiert) ' False : keine Suche in Unterordnern Dim OneItem As String Filter = Trim(Filter) If Right$(Pfad, 1) <> "\" Then Pfad = Pfad & "\" 'ersten Eintrag im Ordner lesen If SubDIR Or (SubDIR = False And Filter = "") Then OneItem = Dir(Pfad & Filter, vbDirectory) 'Ausgabe mit Ordnernamen Else OneItem = Dir(Pfad & Filter) 'Ausgabe ohne Ordnernamen End If 'Eintrag verarbeiten u. nächsten Eintrag lesen While OneItem <> "" If OneItem <> "." And OneItem <> ".." Then 'Ergebnisse sammeln: Pfad & Dateiname Daten.Add (Pfad & OneItem) End If OneItem = Dir 'nächsten Eintrag im Ordner lesen Wend End Sub
Option Explicit Sub Test2() 'Ersatz für Application.FileSearch entwickeln und testen 'mit Rekursion zum Lesen der Unterordner Dim Startpfad As String Dim Daten As New Collection 'gesammelte Ergebinsse Dim Eintrag Dim ii As Long Startpfad = ThisWorkbook.Path 'wenn dieses Programm in Excel läuft 'Startpfad = ActiveDocument.Path 'falls es unter Word laufen soll 'alle Dateien sammeln Call ListFilesInFolder(Daten, Startpfad, True) 'nichts gefunden If Daten.Count = 0 Then MsgBox ("In Ordner " & Startpfad & " Nichts gefunden.") Exit Sub End If 'Ergebnis filtern, z. B. nur Excel-Dateien zulassen For ii = Daten.Count To 1 Step -1 If InStr(Dateiendung_von(Daten(ii)), ".xl") <> 1 Then Daten.Remove ii End If Next ii 'Dateinamen auflisten (oder benutzen) For Each Eintrag In Daten 'Testausgabe im Direktbereich (Funktionen: siehe voriger Abschnitt) Debug.Print Pfadname_von(Eintrag) & " " & Dateiname_von(Eintrag) 'hier könnten dann Ihre weiteren Befehle stehen '... '... '... Next Eintrag End Sub Sub ListFilesInFolder(Daten As Collection, SourceFolderName As String, _ IncludeSubfolders As Boolean) 'alle Dateien in SourceFolder auflisten 'Beispiel: ListFilesInFolder "C:\FolderName\", True Dim FSO Set FSO = CreateObject("Scripting.FileSystemObject") Dim SourceFolder, SubFolder, FileItem Set SourceFolder = FSO.GetFolder(SourceFolderName) For Each FileItem In SourceFolder.Files Daten.Add FileItem.Path Next FileItem If IncludeSubfolders Then For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder Daten, SubFolder.Path, True Next SubFolder End If Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing End Sub
Function Pfadname_von(aa) As String 'Pfadname abtrennen Pfadname_von = Left(aa, InStrRev(aa, "\") - 1) End Function Function Dateiname_von(aa) As String 'Dateiname abtrennen Dateiname_von = Mid(aa, InStrRev(aa, "\") + 1) End Function Function Dateiendung_von(aa) As String 'Dateiendung (mit Punkt) abtrennen If InStrRev(aa, ".") = 0 Then Dateiendung_von = "" Exit Function End If Dateiendung_von = Mid(aa, InStrRev(aa, ".")) End Function
Sub Version_erkennen() 'Office-Version ermitteln Dim Ausgabe As String Select Case Int(Val(Application.Version)) Case 8 Ausgabe = "Excel 97" Case 9 Ausgabe = "Excel 2000" Case 10 Ausgabe = "Excel 2002/XP" Case 11 Ausgabe = "Excel 2003" Case 12 Ausgabe = "Excel 2007" Case 14 Ausgabe = "Excel 2010" Case Is > 14 Ausgabe = "Excel Version > 2010" Case Else MsgBox "Unbekannte Version von Excel" Exit Sub End Select MsgBox Ausgabe, vbInformation 'Hinweis: Es gibt hierfür auch eine Formel, die man 'in Tabellenzellen schreiben kann: =INFO("Version") End Sub
![]() |
![]() |
Und noch ein paar Bücher zur Einführung in die VBA-Programmierung: |
![]() |