Public Sub Suche()
Dim xSearch As String
xSearch = InputBox("Bitte Suchbegriff eingeben")
Dim InPath As String
InPath = "H:\Tests"
If Right(InPath, 1) <> "\" Then InPath = InPath & "\"
If Dir(InPath, vbDirectory) = "" Then
MsgBox "Der Ordner " & InPath & " wurde nicht gefunden.", vbCritical
Exit Sub
End If
Dim found As Boolean, zVerz As Long
Dim WS As Worksheet
Dim WB As Workbook
Dim VWS As Worksheet
Set VWS = ThisWorkbook.Worksheets("Verzeichnis")
Dim f As Range, firstAddress As String
Dim FSO As Object, Element As Object, Datei As Variant, Ordner As Variant
Dim Col As New Collection
Set FSO = CreateObject("Scripting.Filesystemobject")
Set Ordner = FSO.getfolder(InPath)
For Each Datei In Ordner.Files
Select Case LCase(FSO.GetExtensionName(Datei))
Case "xls", "xlsx", "xlsm"
If Left(Datei.Name, 1) <> "~" Then Col.Add Datei
End Select
Next Datei
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False
zVerz = 2
VWS.Columns("A").ClearContents
found = False
For Each Element In Col
If Element.Name <> ThisWorkbook.Name Then
Set WB = Workbooks.Open(Filename:=Element, ReadOnly:=True)
For Each WS In WB.Worksheets
With WS.UsedRange
Set f = .Find(xSearch, LookIn:=xlValues)
If Not f Is Nothing Then
firstAddress = f.Address
Do
VWS.Cells(zVerz, 1).Value = " '" & xSearch & "' Datei: " _
& Chr(13) & Element & " 'Blatt: " & WS.Name & " 'Zelle: " & f.Address(0, 0)
zVerz = zVerz + 1
Set f = .FindNext(f)
Loop While Not f Is Nothing And f.Address <> firstAddress
End If
End With
If found = True Then Exit For
Next WS
If found = False Then Workbooks(Element.Name).Close savechanges:=False
End If
If found = True Then Exit For
Next Element
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Set FSO = Nothing
Exit Sub
err:
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Error: " & vbCrLf & "Fehlernummer: " & err.Number & _
vbCrLf & "Fehlerbeschreibung: " & err.Description, vbOKOnly + vbCritical, "error"
Set FSO = Nothing
End Sub