Suchfunktion über alle Mappen im Verzeichnis

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
nun habe ich mir schon die Mühe gemacht, deshalb zeige ich die Lösung nun noch.
Alle Mappen MÜSSEN geöffnet werden, sonst funktioniert die Suche nicht.
Es ist für den Anwender aber nicht erkennbar, dass Mappen geöffnet werden.
Warum müssen die Hilfetexte überhaupt in verschiedenen Mappen liegen ?
Bietet es sich nicht an, alle in eine Mappe zu packen ?

Option Explicit
Sub MultiSeek_in_Folder()
'By Ramses
'Durchsucht in einem Verzeichnis alle Mappen nach einem Suchbegriff
Dim Suchpfad As String, findStr As String, Dateiform As String, msgTxt As String
Dim qe As Integer, myMatch As String, sAddress As String
Dim wks As Worksheet, wb As Workbook
Dim myRng As Range, totFiles As Integer, i As Integer, gefFile As Variant
Dim oldStatus As Variant
'Variablen füllen
Dateiform = "*.xls"
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll:", "Pfad definieren", Application.DefaultFilePath)
If Suchpfad = "" Then Exit Sub
findStr = InputBox("Geben Sie den Text an der gesucht werden soll", "Textteil", "Suchtext")
If findStr = "" Then Exit Sub
msgTxt = "Soll auf exakte Übereinstimmung mit dem Fragment gesucht werden ? "
msgTxt = msgTxt & vbCrLf & "Bei ""Nein"" werden als Ergebnisse angezeigt,"
msgTxt = msgTxt & vbCrLf & "bei denen nur ein Teil des Textes mit:"" " & findStr & " "" übereinstimmt !"
qe = MsgBox(msgTxt, vbQuestion + vbYesNo, "Suchroutine")
If qe = vbOK Then
    myMatch = xlWhole
Else
    myMatch = xlPart
End If
'Bildschirmaktualisierung abschalten
Application.ScreenUpdating = False 'Nicht ausschalten = True
'Text der Statusbar und alten Status aufnehmen
oldStatus = Application.StatusBar
'Start der Suchroutine
With Application.FileSearch
    .NewSearch
    .LookIn = Suchpfad
    .Filename = Dateiform
    If .Execute() > 0 Then
        totFiles = .FoundFiles.Count
        'Ausgabe in Statusbar
        Application.StatusBar = "Total " & totFiles & " gefunden"
        For i = 1 To .FoundFiles.Count
            gefFile = .FoundFiles(i)
            Set wb = Application.Workbooks.Open(gefFile)
            Application.StatusBar = "Datei " & i & " von " & totFiles & " wird bearbeitet"
            For Each wks In wb.Worksheets
                Set myRng = wks.Cells.Find(What:=findStr, _
                        LookAt:=myMatch, LookIn:=xlFormulas)
                If Not myRng Is Nothing Then
                    sAddress = myRng.Address
                    Do
                        Application.Goto myRng, True
                        'Für die Automation kann die "If"-Anweisung auskommentiert werden
                        If MsgBox("Weiter suchen", vbYesNo + vbQuestion) = vbNo Then
                            GoTo exitsearch
                        End If
                        '--
                        Set myRng = Cells.FindNext(After:=ActiveCell)
                    Loop
                End If
            Next
            wb.Close False
            Set wb = Nothing
        Next i
    End If
    'Exitfor:
End With
MsgBox prompt:="Keine neue Fundstelle!"
exitsearch:
Application.StatusBar = oldStatus
Application.ScreenUpdating = True
End Sub

Code eingefügt mit Syntaxhighlighter 2.5

Der Code muss in ein Modul deiner Arbeitsmappe
Gruss Rainer

Beliebteste Forumthreads (12 Monate)

Suchfunktion über alle Mappen im Verzeichnis

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread