Suchfunktion in VBA
Thomas
Ich hab angefangen in VBA eine Suchfunktion zu schreiben die folgendes macht:
- Suchbegriff suchen und Treffer Zelle in "Fettschrift" darstellen sowie Reihe einblenden
- Alle Reihen ohne Treffer ausblenden
Funktioniert soweit wunderbar bei EINEM Suchbegriff.
Nun hab ich mir gedacht, was ist wenn ich mehrere Suche ?
Als Trennzeichen hab ich mir nun "&" ausgedacht. Das heist bevor die Suche beginnt wird der Suchbegriff "aufgeteilt". Das funzt auch !
z.B. "*Thomas* & *Test*"
-> Thomas
-> Test
Als nächstes Schleif ich meine eigentliche "Suche" nach der Anzahl Suchbegriffen.
Da sucht er mir irgendwie nur ein Suchbegriff und den anderen findet er nicht.
Hab eine Beispieldatei angefügt.
https://www.herber.de/bbs/user/65663.xls
Ich denke das liegt irgendwie an
For u=1 to x
.....
Set rngFundZelle(u) = Sheets(quelle).UsedRange.Find(suchb(u), , xlValues, xlWhole, xlByRows, xlNext, False, False)
.....
next.
'----------------------------------------
Außerdem noch meine frage wie man besser mit arrays umgehen kann.
Am anfang sagt man ja z.B. Dim Test(1 to 100) as Range
Geht das auch anders? Direkt erhöhen im Code?
z.B. Dim Test() as Range
dann Redim Test(1 to1)
'--------------------------------------------
Hier mal der ganze Code
'----------------------------------------------------
Sub Suche()
Dim Suchbegriff
Dim rngFundZelle(1 To 1000) As Range
Dim row(1 To 65000) As Integer
Dim col(1 To 65000) As Integer
Dim suchb(1 To 65000) As String
Application.ScreenUpdating = False
quelle = ActiveSheet.Name
Suchbegriff = ActiveSheet.TextBox1.Value
If Not Suchbegriff = "" Then
Sheets(quelle).Activate
' Suchbegriffe aufteilen
x = 0
' Suche straten nach &
'On Error Resume Next
Zähler = 0
Do
Nummer = InStr(1, Suchbegriff, "&")
'If nummer > 0 Then
'y = y + 1
Zähler = Zähler + 1
' länge = Len(Suchbegriff) - Nummer
suchb(Zähler) = Left(Suchbegriff, Nummer)
If Nummer = 0 Then
suchb(Zähler) = Suchbegriff
End If
Suchbegriff = Replace(Suchbegriff, suchb(Zähler), "")
suchb(Zähler) = Replace(suchb(Zähler), " & ", "")
suchb(Zähler) = Replace(suchb(Zähler), " & ", "")
suchb(Zähler) = Replace(suchb(Zähler), " & ", "")
suchb(Zähler) = Replace(suchb(Zähler), " &", "")
suchb(Zähler) = Replace(suchb(Zähler), " &", "")
suchb(Zähler) = Replace(suchb(Zähler), " &", "")
suchb(Zähler) = Replace(suchb(Zähler), "&", "")
'bla = Right(bla, nummer)
'End If
' Suchbegriff = suchb(Zähler)
Loop While Nummer 0
x = 1
For u = 1 To Zähler
Suchbegriff = suchb(u)
' suche starten
Set rngFundZelle(u) = Sheets(quelle).UsedRange.Find(suchb(u), , xlValues, xlWhole, xlByRows, _
xlNext, False, False)
x = x - 1
'x = 0
If Not rngFundZelle(u) Is Nothing Then
firstAddress = rngFundZelle(u).Address
x = x + 1
row(x) = rngFundZelle(u).row
col(x) = rngFundZelle(u).Column
Sheets(quelle).Cells(row(x), col(x)).Select
' Nach weiteren Treffern suchen und treffer zählen (x)
Do
Set rngFundZelle(u) = ActiveSheet.UsedRange.FindNext(after:=ActiveCell)
row(x) = rngFundZelle(u).row
col(x) = rngFundZelle(u).Column
Sheets(quelle).Cells(row(x), col(x)).Select
x = x + 1
Loop While Not rngFundZelle(u) Is Nothing And rngFundZelle(u).Address firstAddress
Else
MsgBox Suchbegriff & " nicht gefunden !"
' Exit Sub
End If
Next
' Anzahl Treffer
x = x - 1
MsgBox x & " mal gefunden !"
' Reihen ohne Treffer ausblenden und Trefferzelle markieren
For j = 1 To x
Sheets(quelle).Cells(row(j), col(j)).Font.Bold = True
Next
Zeilenanzahl = Sheets(quelle).Cells(Rows.Count, 5).End(xlUp).row
For m = 1 To Zeilenanzahl
Treffer = 0
For j = 1 To x
If m = row(j) Then
Treffer = 1
' zcol = col(j)
End If
Next
If Treffer = 0 Then
If m > 4 Then
Sheets(quelle).Rows(m).EntireRow.Hidden = True
End If
Else
Sheets(quelle).Rows(m).EntireRow.Hidden = False
' Sheets(quelle).Cells(i, zcol).Font.Size = 20
' Sheets(quelle).Cells(i, zcol).Font.Bold = True
End If
Next
Else:
Sheets(quelle).Rows("5:65000").EntireRow.Hidden = False '.Select
Sheets(quelle).UsedRange.Font.Bold = False
Rows("1:4").EntireRow.Font.Bold = True
' Selection.EntireRow.Hidden = False
End If
ActiveSheet.TextBox1.Value = ""
Application.ScreenUpdating = True
End Sub
'----------------------Ich hoffe ihr könnt mir weiterhelfen
gruß
Thomas