Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1112to1116
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Suchfunktion in VBA

Suchfunktion in VBA
Thomas
Hallo zusammen
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

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Suchfunktion in VBA
08.11.2009 10:02:25
Josef
Hallo Thomas,
dieser Code direkt unter CommandButton1 genügt.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Private Sub CommandButton1_Click()
  Dim strSearch() As String, strFirst As String
  Dim rngF As Range, rng As Range
  Dim lngIndex As Long
  
  On Error GoTo Errexit
  Application.ScreenUpdating = False
  
  Me.Range("A5:A" & Rows.Count).EntireRow.Hidden = False
  
  If Len(Trim(Me.TextBox1.Text)) > 0 Then
    strSearch = Split(Me.TextBox1.Text, "&")
    For lngIndex = 0 To UBound(strSearch)
      Set rng = Me.UsedRange.Find(what:=strSearch(lngIndex), lookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
      
      If Not rng Is Nothing Then
        strFirst = rng.Address
        
        Do
          If rng.row > 4 Then
            If rngF Is Nothing Then
              Set rngF = rng
            Else
              Set rngF = Union(rngF, rng)
            End If
          End If
          
          Set rng = Me.UsedRange.FindNext(rng)
          
        Loop While Not rng Is Nothing And strFirst <> rng.Address
        
      End If
    Next
    
    If Not rngF Is Nothing Then
      Me.Range("A5:A" & Rows.Count).EntireRow.Hidden = True
      rngF.EntireRow.Hidden = False
    End If
  End If
  Errexit:
  Application.ScreenUpdating = True
  Set rng = Nothing
  Set rngF = Nothing
End Sub

Gruß Sepp

Anzeige
AW: Suchfunktion in VBA
09.11.2009 22:58:59
Thomas
Sorry die späte Antwort. Vielen Dank hat mir geholfen. Habs noch ein bischen angepasst und jetzt funzt es wunderbar, Was wäre ich nur ohne euch..... ;-)
gruß
Thomas

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige