Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1096to1100
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Suche mit mehreren Filenamen

Suche mit mehreren Filenamen
Lang
Hallo Excelfreunde,
mit der nachfolgenden Prozedur finde ich in "C:\" alle Dateien mit dem (Beispiel-)Namen "abcdefgh".
Wie muss die Prozedur ergänzt werden, damit sie gleichzeitig auch Namensteile wie "ab", "cd", "ef" usw. in die Suche einbindet und diese in der Tabelle "Fundus" ausgegeben werden?
(Das Grundgerüst der Prozedur stammt aus diesem Forum. Danke!)
Sub SucheNach_abcgefgh_In_C()
Dim anz1 As Integer
Dim anz2 As Integer
Dim Zelle As Range
With Application.FileSearch
.Filename = "abcgefgh"
.LookIn = "C:\"
.SearchSubFolders = True
.Execute
If .FoundFiles.Count = 0 Then
Exit Sub
Else
Worksheets.Add.Name = "Fundus"
Set Zelle = Range("A2")
anz1 = 0
anz2 = 0
For anz1 = 1 To .FoundFiles.Count
Zelle.Value = .FoundFiles(anz1)
anz2 = anz2 + 1
Set Zelle = Zelle.Offset(1, 0)
Next anz1
End If
End With
End Sub
Danke vorab!
Gruß Klaus
P.S.: Dies ist meine erste Suche ohne "select". Dank diesem Forum!

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Suche mit mehreren Filenamen
28.08.2009 20:53:47
Josef
Hallo Klaus,
eine Möglichkeit.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit


Sub searchFiles()
  Dim objFiles() As Object, varNames As Variant
  Dim result As Long, lngIndex As Long
  Dim objSh As Worksheet
  
  result = FileSearchINFO(objFiles, "C:\", "*ab*;*cd*;*ef*", True)
  
  If result <> 0 Then
    Redim varNames(1 To UBound(objFiles) + 1, 1 To 1)
    
    For lngIndex = 0 To UBound(objFiles)
      varNames(lngIndex + 1, 1) = objFiles(lngIndex).Name
    Next
    
    On Error Resume Next
    Set objSh = Sheets("Fundus")
    On Error GoTo 0
    If objSh Is Nothing Then
      Set objSh = ThisWorkbook.Worksheets.Add
      objSh.Name = "Fundus"
    Else
      objSh.Range("A2:A" & CStr(Rows.Count)) = ""
    End If
    With objSh
      .Range(.Cells(2, 1), .Cells(UBound(varNames, 1) + 1, 1)) = varNames
      .Range(.Cells(2, 1), .Cells(UBound(varNames, 1) + 1, 1)).Columns.AutoFit
    End With
  End If
  
  Set objSh = Nothing
End Sub

'by J.Ehrensberger
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
    Optional ByVal SubFolders As Boolean = False) As Long

  
  '# PARAMETERINFO:
  '# Files: Datenfeld zur Ausgabe der Suchergebnisse
  '# InitialPath: String der das zu durchsuchende Verzeichnis angibt
  '# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
  '# Beispiele: "*.txt" - Findet alle Textdateien
  '# "*name*" - Findet alle Dateien mit "name" im Dateinamen
  '# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
  '# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)
  
  
  Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
  Dim intC As Integer, varFiles As Variant
  
  Set fobjFSO = CreateObject("Scripting.FileSystemObject")
  
  Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
  
  On Error GoTo ErrExit
  
  If InStr(1, FileName, ";") > 0 Then
    varFiles = Split(FileName, ";")
  Else
    Redim varFiles(0)
    varFiles(0) = FileName
  End If
  For Each ffsoFile In ffsoFolder.Files
    If Not ffsoFile Is Nothing Then
      For intC = 0 To UBound(varFiles)
        If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
          If IsArray(Files) Then
            Redim Preserve Files(UBound(Files) + 1)
          Else
            Redim Files(0)
          End If
          Set Files(UBound(Files)) = ffsoFile
          Exit For
        End If
      Next
    End If
  Next
  
  If SubFolders Then
    For Each ffsoSubFolder In ffsoFolder.SubFolders
      FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
    Next
  End If
  
  If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
  ErrExit:
  Set fobjFSO = Nothing
  Set ffsoFolder = Nothing
End Function

Gruß Sepp

Anzeige
Danke!
29.08.2009 11:44:11
Lang
Hallo Sepp,
vielen Dank! Ist ja riesig!
Gruß Klaus

307 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige