Volltextsuche läuft nicht korrekt
Pascal
in einer grossen Excel-Datenbank mit über hundert Tabellenblättern hab ich mir eine Volltextsuche eingebaut.
Der Code wurde vor einiger Zeit schon mal mühsam zusammengebastelt:
Option Explicit
Private Sub CommandButton1_Click()
'Sheets("Suche").UsedRange.Clear
On Error Resume Next
Dim oWS As Worksheet
Dim rngUnion As Range, rngFund As Range
Dim strErste$, strSuchBegriff$
Dim MaxRow As Long
Dim WS_Suche As Worksheet
'Tabelle für die Auflistung
Set WS_Suche = Sheets("Suche")
Such_Formular.CommandButton1.Visible = False
strSuchBegriff = Such_Formular.TextBox1.Value
If StrPtr(strSuchBegriff) = 0 Then
Exit Sub
End If
MaxRow = 1
Sheets("Suche").UsedRange.Clear
For Each oWS In ThisWorkbook.Worksheets
If oWS.Name WS_Suche.Name Then
Set rngFund = oWS.UsedRange.Find(strSuchBegriff, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not rngFund Is Nothing Then
Set rngUnion = Intersect(oWS.UsedRange, oWS.Rows(rngFund.Row))
strErste = rngFund.Address
Set rngFund = oWS.UsedRange.FindNext(rngFund)
Do While strErste rngFund.Address
Set rngUnion = Union(Intersect(oWS.UsedRange, oWS.Rows(rngFund.Row)), rngUnion)
Set rngFund = oWS.UsedRange.FindNext(rngFund)
Loop
End If
If Not rngUnion Is Nothing Then
For Each rngUnion In rngUnion.Areas
rngUnion.Copy WS_Suche.Cells(MaxRow, 1)
MaxRow = MaxRow + rngUnion.Rows.Count
Next rngUnion
Set rngUnion = Nothing
End If
End If
Next oWS
If MaxRow > 1 Then
Such_Formular.CommandButton3.Visible = True
Else
Such_Formular.CommandButton3.Visible = False
End If
Such_Formular.TextBox1.Text = ""
End Sub
Nun hab ich bemerkt, dass mein obiger Code wohl doch nicht sauber funktioniert. Denn.... Suche ich nach einem Wort, Namen oder Begriff den es zu 100% gibt in der Datenbank, wird dieser nicht gefunden.Wo könnte sich ein Fehler eingeschlichen haben bei meinem Code ?
oder ...
wo müsste ich bei meinem Code was ändern ?
Danke herzlich für die Hilfe !