Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1192to1196
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
Suchen nach Datei
Karsten
Hallo...
ich möchte über Excel nach einer bestimmten Datei suchen.
in A1 steht der Pfad (z.B. C:\)
in A2 möchte ich den Suchtext eingeben (z.B. Schnee)
in A3 und darunter sollen alle Suchergebnisse aufgelistet werden, welche in diesem Zusammenhang gefunden wurden (z.B. Schneeball, Schneeflocke, Leise rieselt der Schnee usw.).
Vielleicht kann mir jemand dabei helfen.
Besten Dank.
Gruß
Karsten

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Suchen nach Datei
22.12.2010 21:23:16
Josef

Hallo Karsten,
kopiere folgenden Code in das Modul der entsprechenden Tabelle (Rechtsklick auf Blattregister > Code Anzeigen > in das rechte Fenster einfügen).

' **********************************************************************
' Modul: Tabelle3 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim strDir As String, strSearch As String, strFile As String
  Dim lngRow As Long
  
  On Error GoTo ErrExit
  
  lngRow = 2
  If Not Intersect(Target, Range("A1:A2")) Is Nothing Then
    Application.EnableEvents = False
    Range("A3:A" & Rows.Count).ClearContents
    If Range("A1") <> "" And Range("A2") <> "" Then
      strDir = Range("A1")
      strSearch = Range("A2")
      strDir = strDir & IIf(Right(strDir, 1) = "\", "", "\")
      strFile = Dir(strDir & "*" & strSearch & "*", vbNormal)
      Do While strFile <> ""
        lngRow = lngRow + 1
        Me.Hyperlinks.Add Anchor:=Cells(lngRow, 1), _
          Address:=strDir & strFile, SubAddress:="", _
          TextToDisplay:=strFile
        strFile = Dir
      Loop
    End If
  End If
  
  ErrExit:
  Application.EnableEvents = True
End Sub

Gruß Sepp

Anzeige
AW: Suchen nach Datei
23.12.2010 07:05:19
Karsten
Hallo Sepp,
danke. Kannst du mir die Sache bitte noch mit Einbeziehung der Unterordner schreiben? Das hab ich doch vergessen zu schreiben.
Gruß
Karsten
AW: Suchen nach Datei
23.12.2010 14:41:42
Josef

Hallo Karsten,
dann wird's länger.

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim objFiles() As Object
  Dim strDir As String, strSearch As String, strFile As String
  Dim lngIndex As Long, lngRet As Long
  
  On Error GoTo ErrExit
  
  If Not Intersect(Target, Range("A1:A2")) Is Nothing Then
    Application.EnableEvents = False
    Range("A3:A" & Rows.Count).ClearContents
    If Range("A1") <> "" And Range("A2") <> "" Then
      If Dir(Range("A1").Text, vbDirectory) <> "" Then
        lngRet = FileSearchINFO(objFiles, Range("A1").Text, "*" & Range("A2").Text & "*", True)
        If lngRet > 0 Then
          For lngIndex = 0 To lngRet - 1
            Me.Hyperlinks.Add Anchor:=Cells(lngIndex + 3, 1), _
              Address:=objFiles(lngIndex).Path, SubAddress:="", _
              TextToDisplay:=objFiles(lngIndex).Name
          Next
        End If
      End If
    End If
  End If
  
  ErrExit:
  Application.EnableEvents = True
End Sub

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
AW: Suchen nach Datei
23.12.2010 14:48:40
Karsten
Hallo Sepp,
nochmal allerbesten Dank und schöne Feiertage.
Gruß
Karsten
AW: Suchen nach Datei
23.12.2010 12:58:07
Tino
Hallo,
ich habe es mal so versucht, Teile vom Code stammen von Nepumuk.
kommt als Code in Modul1
Option Explicit 
 
Public Sub FindFile() 
Dim FileArray() 
Dim lngFilecount As Long 
Dim strFolder As String, Pfad As String, Suchbegriff As String 
 
Suchbegriff = InputBox("Suchbegriff eingeben." & vbCr & _
              "Verwenden Sie '*' als Platzhalter" & vbCr & _
              "Bsp: *schnee* oder *.xls", "Suche nach", "*.*") 
 
If StrPtr(Suchbegriff) = 0 Then Exit Sub 
 
strFolder = Trim$(fncGetFolder(sPath:="C:\")) 
     
If strFolder <> "" Then 
    If Right$(strFolder, 1) <> "\" Then strFolder = strFolder & "\" 
    Application.ScreenUpdating = False 
     
        Range("A2", Cells(Rows.Count, 1)).ClearContents 
         
        'Suchordner - Suchformat - Zähler - False ohne Subfolder 
        FindFiles FileArray, strFolder, Suchbegriff, lngFilecount, True 
         
        If lngFilecount > 0 Then 
            If lngFilecount > Rows.Count - 1 Then 
                MsgBox "Zu viele Treffer, schrenken Sie die Suche weiter ein!" 
            Else 
                FileArray = Application.Transpose(FileArray) 
                Cells(2, 1).Resize(Ubound(FileArray), 1) = FileArray 
            End If 
        End If 
     
        Columns(1).AutoFit 
     
    Application.ScreenUpdating = True 
End If 
End Sub 
kommt als Code in Modul2
Option Explicit 
 
Option Private Module 
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, _
    lpFindFileData As WIN32_FIND_DATA) As Long 
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, _
    lpFindFileData As WIN32_FIND_DATA) As Long 
Private Declare Function FindClose Lib "kernel32" ( _
    ByVal hFindFile As Long) As Long 
 
Private Enum FILE_ATTRIBUTE 
    FILE_ATTRIBUTE_READONLY = &H1 
    FILE_ATTRIBUTE_HIDDEN = &H2 
    FILE_ATTRIBUTE_SYSTEM = &H4 
    FILE_ATTRIBUTE_DIRECTORY = &H10 
    FILE_ATTRIBUTE_ARCHIVE = &H20 
    FILE_ATTRIBUTE_NORMAL = &H80 
    FILE_ATTRIBUTE_TEMPORARY = &H100 
End Enum 
 
Private Const INVALID_HANDLE_VALUE = -1& 
Private Const MAX_PATH = 260& 
 
Private Type FILETIME 
    dwLowDateTime As Long 
    dwHighDateTime As Long 
End Type 
 
Private Type WIN32_FIND_DATA 
    dwFileAttributes As Long 
    ftCreationTime As FILETIME 
    ftLastAccessTime As FILETIME 
    ftLastWriteTime As FILETIME 
    nFileSizeHigh As Long 
    nFileSizeLow As Long 
    dwReserved0 As Long 
    dwReserved1 As Long 
    cFileName As String * MAX_PATH 
    cAlternate As String * 14 
End Type 
 
Private Declare Function MoveWindow Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long 
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long 
Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByRef lpRect As RECT) As Long 
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
    lpbi As InfoT) As Long 
Private Declare Function CoTaskMemFree Lib "ole32" ( _
    ByVal hMem As Long) As Long 
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
    ByVal lpStr1 As String, _
    ByVal lpStr2 As String) As Long 
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
    ByVal pList As Long, _
    ByVal lpBuffer As String) As Long 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassname As String, _
    ByVal lpWindowName As String) As Long 
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    wParam As Any, _
    lParam As Any) As Long 
 
Private Type InfoT 
    hwnd As Long 
    Root As Long 
    DisplayName As Long 
    Title As Long 
    Flags As Long 
    FName As Long 
    lParam As Long 
    Image As Long 
End Type 
 
Private Type RECT 
    Left As Long 
    Top As Long 
    Right As Long 
    Bottom As Long 
End Type 
 
Public Enum BIF_Flag 
    BIF_RETURNONLYFSDIRS = &H1 
    BIF_DONTGOBELOWDOMAIN = &H2 
    BIF_STATUSTEXT = &H4 
    BIF_RETURNFSANCESTORS = &H8 
    BIF_EDITBOX = &H10 
    BIF_VALIDATE = &H20 
    BIF_NEWDIALOGSTYLE = &H40 
    BIF_BROWSEINCLUDEURLS = &H80 
    BIF_BROWSEFORCOMPUTER = &H1000 
    BIF_BROWSEFORPRINTER = &H2000 
    BIF_BROWSEINCLUDEFILES = &H4000 
    BIF_SHAREABLE = &H8000 
End Enum 
 
Private Const SM_CXFULLSCREEN = &H10 
Private Const SM_CYFULLSCREEN = &H11 
 
Private Const BFFM_SETSELECTION = &H466 
Private Const BFFM_INITIALIZED = &H1 
 
Private s_BrowseInitDir As String 
 
Public Function fncGetFolder( _
        Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
        Optional ByVal lFlag As BIF_Flag = BIF_RETURNONLYFSDIRS, _
        Optional ByVal sPath As String = "C:\") As String 
    Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String 
    s_BrowseInitDir = sPath 
    With xl 
        .hwnd = FindWindow("XLMAIN", vbNullString) 
        .Root = 0 
        .Title = lstrcat(sMsg, "") 
        .Flags = lFlag 
        .FName = FuncCallback(AddressOf BrowseCallback) 
    End With 
    IDList = SHBrowseForFolder(xl) 
    If IDList <> 0 Then 
        FolderName = Space(256) 
        RVal = SHGetPathFromIDList(IDList, FolderName) 
        CoTaskMemFree (IDList) 
        FolderName = Trim$(FolderName) 
        FolderName = Left$(FolderName, Len(FolderName) - 1) 
    End If 
    fncGetFolder = FolderName 
End Function 
 
Private Function BrowseCallback( _
        ByVal hwnd As Long, _
        ByVal uMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long 
    If uMsg = BFFM_INITIALIZED Then 
        Call SendMessage(hwnd, BFFM_SETSELECTION, ByVal 1&, ByVal s_BrowseInitDir) 
        Call CenterDialog(hwnd) 
    End If 
    BrowseCallback = 0 
End Function 
 
Private Function FuncCallback(ByVal nParam As Long) As Long 
    FuncCallback = nParam 
End Function 
 
Private Sub CenterDialog(ByVal hwnd As Long) 
    Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer 
    Dim DlgWidth As Integer, DlgHeight As Integer 
    GetWindowRect hwnd, WinRect 
    DlgWidth = WinRect.Right - WinRect.Left 
    DlgHeight = WinRect.Bottom - WinRect.Top 
    ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN) 
    ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN) 
    MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
        (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1 
End Sub 
 
Sub FindFiles(FileArray(), ByVal strFolderPath As String, ByVal strSearch As String, _
        ByRef lngFilecount As Long, Optional SubFolder As Boolean = True) 
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String 
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD) 
    If lngSearch <> INVALID_HANDLE_VALUE Then 
        GetFilesInFolder FileArray(), strFolderPath, strSearch, lngFilecount 
        Do 
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then 
                strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1) 
                If SubFolder = False Then Exit Sub 'ohne Unterordner 
                If (strDirName <> ".") And (strDirName <> "..") Then _
                    FindFiles FileArray(), strFolderPath & strDirName & "\", strSearch, lngFilecount 
            End If 
        Loop While FindNextFile(lngSearch, WFD) 
        FindClose lngSearch 
    End If 
End Sub 
 
Sub GetFilesInFolder(FileArray(), ByVal strFolderPath As String, ByVal strSearch As String, _
        ByRef lngFilecount As Long) 
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String 
    lngSearch = FindFirstFile(strFolderPath & strSearch, WFD) 
    If lngSearch <> INVALID_HANDLE_VALUE Then 
        Do 
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then 
                strFileName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1) 
                Redim Preserve FileArray(lngFilecount) 
                FileArray(lngFilecount) = strFolderPath & strFileName 'auflisten in Array 
                lngFilecount = lngFilecount + 1 
            End If 
        Loop While FindNextFile(lngSearch, WFD) 
        FindClose lngSearch 
    End If 
End Sub 
 
Gruß Tino
Anzeige
AW: Suchen nach Datei
23.12.2010 14:03:15
Karsten
Hallo Tino,
danke, ich habe eine Weile gebraucht, bis ich rausbekam wie es geht. Nur, die Ordnerabfrage und die Inputbox ist mir zu umständlich. Läßt sich das nicht über A1 und A2 regeln?
Hast du eine Ahnung, was das in Sepp's Code bedeutet?
strDir = strDir & IIf(Right(strDir, 1) = "\", "", "\")
Kommt da nicht möglicherweise etwas hinein, was die Unterordner mit einschließt?
Gruß
Karsten
schreib doch mal..
23.12.2010 14:08:59
robert
Hi,
zb. in A1 C:\Dein Unterordner\
gruß
robert

96 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige