Suchresultate auf Tabellenblatt auflisten lassen
28.06.2013 08:54:25
Pascal
Vor einiger Zeit schon hatte ich - dank der grossartigen Forumshilfe hier - ein Vorschlag für eine Matrix-Suche erhalten, welche ich dann auch in ein grösseres Projekt habe übernehmen können.
An dieser Stelle nochmals herzlichen Dank für die damalige Hilfe!
In der Beilage nochmals das Beispiel welches ich seinerzeits erhalten hatte.
https://www.herber.de/bbs/user/86100.xls
Nun möchte ich das Beispiel so anpassen, dass mir die Fundstellen nicht selektiert werden, sonder alle Fundstellen in einem separaten Tabellenblatt Namens "Suche_1" aufgelistet werden.
Es soll auch keine Frage kommen... "wollen Sie weitersuchen" sondern ... es sollen gemäss Suchmatrix (siehe Beispielsdatei) solange gesucht werden, bis alle entsprechenden Tabellenblätter durchsucht wurden.
Alle Fundstellen sollen dann also auf dem Tabellenblatt "Suche_1" aufgelistet werden.
(mit der Idee, dass man dann von diesem Tabellenblatt mit einem Doppelklick auf die entsprechende Fundstelle, zu dieser springen kann)
Kann man diesen Code dementsprechend so erweitern oder umbauen ?
Danke Euch herzlich für Eure Tips und erneute Hilfe
Private Sub CB_Suchen_Click()
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String, sFind As String
Dim bolSuchen As Boolean, bolSuchenEnde As Boolean
sFind = Me.tbox_Suchbegriff
If sFind = "" Then GoTo Beenden
For Each wks In Worksheets
'Prüfen ob Blatt durchsucht werden soll
With wksMatrix
If LCase(Application.WorksheetFunction.VLookup(wks.Name, .Range(.Cells(2, 1), _
.Cells(.Rows.Count, 1).End(xlUp).Offset(0, Me.ListBox_Suche.ListCount + 1)), _
Me.ListBox_Suche.ListIndex + 2, False)) = "x" Then
bolSuchen = True
Else
bolSuchen = False
End If
End With
If bolSuchen = True Then
Set rng = wks.Cells.Find(what:=sFind, _
lookat:=xlWhole, LookIn:=xlValues)
If Not rng Is Nothing Then
sAddress = rng.Address
Do
Application.Goto rng, True
Application.Goto Reference:=Range("A1"), Scroll:=True
Range(rng.Address).Select
If MsgBox("Soll die Suche fortgesetzt werden ?", _
vbYesNo + vbQuestion, "Frage an " & _
Application.UserName & ":") = vbNo Then
bolSuchenEnde = True
Exit For
End If
Set rng = Cells.FindNext(after:=ActiveCell)
If rng.Address = sAddress Then Exit Do
Loop
End If
End If
Next wks
If bolSuchenEnde = True Then
Unload Me
Else
MsgBox "Es gibt keine neue Fundstelle !", vbYes + vbInformation, _
"Hinweis an " & Application.UserName & ":"
End If
Beenden:
End Sub