Willkommen

Pivottabelle

Spezialfilter

Formeln

Zellformate

Bedingte Formate

Gültigkeit

Programmierung

UDF - Funktionen

Tipps & Tricks

Webabfrage

Fehlersuche

Farbindex

Shortcuts

Limitationen

Downloads

Links

Kontakt

Disclaimer

Impressum

Suchfunktionen mit farblicher Markierung
 
Ein kleiner Code, der wie in diesem Beispiel in Spalte A & B nach einem Suchbegriff schaut, und diesen dann grau markiert.
 
Nach Klick auf den Button "Suche"
 
 
 
 
 
 
Hier z.B nach "Arc*"
 
 
 
Das Ergebnis
 
 
 
 
Option Explicit
 
Public Sub Woerter_finden()
'Code für ein allgemeines Modul
'*********************************
'Autor: Jürgen Hennekes
'*********************************
Dim Zelle As Range
Dim FirstAddress
Dim lngX As Long
Dim strInbox As String
 
strInbox = InputBox("Bitte einen Suchbegriff eingeben." & vbCr & _
"Die Eingabe von Sternchen* als Joker ist ebenfalls möglich", "SUCHE", "zB Adress*")
If strInbox = "" Then
Exit Sub
Else
With Worksheets("Tabelle1").Range("A2:B100") '<- Tabellenblatt und Bereich bitte anpassen
    .Interior.ColorIndex = xlNone
    Set Zelle = .Find(strInbox, LookIn:=xlValues)
    If Not Zelle Is Nothing Then
        FirstAddress = Zelle.Address
        Do
            Zelle.Interior.ColorIndex = 15 'Die Farbe bitte ebenfalls anpassen.
            lngX = lngX + 1
            Set Zelle = .FindNext(Zelle)
        Loop While Not Zelle Is Nothing And Zelle.Address <> FirstAddress
    End If
End With
End If
If lngX = 0 Then
MsgBox "Die Suche nach [" & strInbox & "] ergab leider keinen Treffer."
Else
MsgBox "Der Suchbegriff [" & strInbox & "] wurde " & lngX & "x gefunden."
End If
End Sub
 
 
 
 

 
Damit gleichzeitig mehrere Begriffe gesucht werden können, hier noch eine Codeerweiterung.
 
Public Sub Woerter_finden()
'Code für ein allgemeines Modul
'******************************
'Autor: Jürgen Hennekes
'******************************
Dim arr()
Dim rngBereich As Range
Dim intI As Integer
Dim Msg As String
Dim SPL
Dim strInbox As String
Dim strWord As String
strInbox = InputBox("Bitte einen Suchbegriff eingeben." & vbCr & _
"Die Eingabe von Sternchen* als Joker ist ebenfalls möglich." & vbCr & _
"Mehrere Suchbegriffe bitte durch ein Komma trennen", "SUCHE", "zB Adress*")
 
Msg = "Die Suche ergab folgende Treffer:" & vbCr & vbCr
 
 
Set rngBereich = Worksheets("Tabelle1").Range("A1:B100") 'Bitte den Suchbereich anpassen
'Set rngBereich = Worksheets("Tabelle1").UsedRange         'Alternativ für alle Zellen in Tabelle1
 
If strInbox = "" Then
Exit Sub
Else
 
rngBereich.Interior.ColorIndex = xlNone
 
SPL = Split(strInbox, ",")
For intI = 0 To UBound(SPL)
  ReDim Preserve arr(0 To intI)
  strWord = LTrim(RTrim(SPL(intI)))
  arr(intI) = arr(intI) + fncSuche(strWord, rngBereich)
  Msg = Msg & strWord & " -> " & arr(intI) & "x" & vbCr
Next
End If
 
MsgBox Msg
 
End Sub
 
 
Public Function fncSuche(ByVal strWord As String, rngBereich As Range) As Long
Dim Zelle As Range
Dim FirstAddress
With rngBereich
    Set Zelle = .Find(strWord, LookIn:=xlValues)
    If Not Zelle Is Nothing Then
        FirstAddress = Zelle.Address
        Do
            Zelle.Interior.ColorIndex = 15 'Die Farbe bitte ebenfalls anpassen.
            fncSuche = fncSuche + 1
            Set Zelle = .FindNext(Zelle)
        Loop While Not Zelle Is Nothing And Zelle.Address <> FirstAddress
    End If
End With
End Function