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
|
||||||
