Suchergebnisse anzeigen

Sub Suchen_und_Anzeigen_neu()
Dim Meldung         As Byte, Pos        As Byte
Dim Schleife        As Byte, y          As Byte
Dim Begriff, Suchen()                   As Variant
Dim Bereich                             As Range
Dim n%, x%, xZelle%, yZelle%
Dim xTabelle$(), Adresse$(), xWorkbook$(), Text$
Dim arrWkb As Variant, varWkb, wkb As Workbook
Dim wksAnzeige As Worksheet
' Suchbegriff eingeben
Begriff = InputBox _
("Bitte den zu suchenden Wert eingeben." & vbCrLf & _
"ENTER ohne Wert = Abbruch", "S U C H M O D U S")
If Begriff = "" Then Exit Sub
Pos = InStr(Begriff, "+")
If Pos Then
ReDim Suchen(2)
Suchen(1) = Left(Begriff, Pos - 1)
Suchen(2) = Right(Begriff, Len(Begriff) - Pos)
Schleife = 2
Else
ReDim Suchen(1)
Suchen(1) = Begriff
Schleife = 1
End If
x = 1 'Zähler für gefundene Zellen
DateiAuswahl:
'zu durchsuchende Datei(en) auswählen
arrWkb = Application.GetOpenFilename( _
Filefilter:="Excel (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", _
Title:="Bitte zu durchsuchende Datei(en) auswählen", _
MultiSelect:=True)
If Not IsArray(arrWkb) Then Exit Sub
Application.ScreenUpdating = False
' Eigentlicher Suchvorgang (in allen Tabellenblättern)
For Each varWkb In arrWkb
Set wkb = Workbooks.Open(Filename:=varWkb, ReadOnly:=True)
For y = 1 To Schleife
For n = 1 To wkb.Sheets.Count
' Letzte Zelle des Bereiches ermitteln. Diese Zelle wird als Startzelle für
' die Suche deffiniert, da Suche nach dieser Zelle, also in erster Zelle
' des Bereiches beginnt.
'Bereich festlegen
Set Bereich = wkb.Worksheets(n).UsedRange
With wkb.Worksheets(n).Range(Bereich.Address)
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End With
With wkb.Sheets(n).Range(Bereich.Address)
Set c = .Find(Suchen(y), After:=Cells(yZelle, xZelle), LookIn:=xlValues)
If Not c Is Nothing Then
ErsteAdresse = c.Address
Do
ReDim Preserve Adresse(x): ReDim Preserve xTabelle(x)
ReDim Preserve xWorkbook(x)
xWorkbook(x) = wkb.Name
xTabelle(x) = wkb.Sheets(n).Name
Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
Set c = .FindNext(c)
x = x + 1
Loop While Not c Is Nothing And c.Address  ErsteAdresse
End If
End With
Next n
Next y
wkb.Close savechanges:=False
Next varWkb
Application.ScreenUpdating = True
If MsgBox("Weitere Dateien nach dem Suchbegriff """ & Begriff _
& """ durchsuchen?", vbYesNo + vbQuestion, "S U C H M O D U S") = vbYes Then _
GoTo DateiAuswahl
' Die Anzahl der gefundenen Werte ist (x - 1), wenn keiner
' gefunden wurde dann ist x = 1
Select Case x
Case 1
Meldung = MsgBox("Es wurde kein übereinstimmender Wert gefunden", _
vbOKOnly, "G E F U N D E N E   W E R T E")
Exit Sub
Case Else
Meldung = MsgBox("Es wurden " & (x - 1) & " Übereinstimmungen gefunden.", _
vbOKOnly, "G E F U N D E N E   W E R T E")
Application.ScreenUpdating = False
'Tabelle einfügen
Set wkb = Application.Workbooks.Add(Template:=xlWBATWorksheet)
Set wksAnzeige = wkb.Worksheets(1)
On Error Resume Next
With wksAnzeige
.Name = "Auswertung"
.Cells(1, 1) = "Suchbegriff"
.Cells(1, 2) = Begriff
.Cells(2, 1) = "Workbook"
.Cells(2, 2) = "Tabelle"
.Cells(2, 3) = "Zelle"
.Cells(3, 1).Select
ActiveWindow.FreezePanes = True
For n = 1 To x - 1
.Cells(n + 2, 1) = xWorkbook(n)
.Cells(n + 2, 2) = xTabelle(n)
.Cells(n + 2, 3) = Adresse(n)
Next n
.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Select
End Sub