03.08.2019, 16:35
Hallo zusammen,
ich habe da im Netz ein tolles VBA-Skript von "ransi" für die Suche und das Zählen nach Begriffen gefunden und etwas auf meinen Bedarf abgeändert. Funktioniert toll aber eines bekomme ich nicht gebacken.
Ich suche nach Namen in einem benannten Bereich. Ich will aber nur ganze Namen finden z.B. "Wolf". Wenn ähnliche Worte wie "Wolfgang" vorkommen, wird dieses Wort auch mitgezählt.
DAs soll natürlich nicht sein.
Hier mal der Code. Wie müsste der abgeändert werden dass die Suche sich nur auf ganze Worte stürzt und nicht auch noch auf Teilstrings?
Vielleicht kann mir jemand helfen?
ich habe da im Netz ein tolles VBA-Skript von "ransi" für die Suche und das Zählen nach Begriffen gefunden und etwas auf meinen Bedarf abgeändert. Funktioniert toll aber eines bekomme ich nicht gebacken.
Ich suche nach Namen in einem benannten Bereich. Ich will aber nur ganze Namen finden z.B. "Wolf". Wenn ähnliche Worte wie "Wolfgang" vorkommen, wird dieses Wort auch mitgezählt.
DAs soll natürlich nicht sein.
Hier mal der Code. Wie müsste der abgeändert werden dass die Suche sich nur auf ganze Worte stürzt und nicht auch noch auf Teilstrings?
Code:
Sub SucheNamen()
Dim Regex As Object
Dim M As Object
Dim Bereich As Range
Dim sTitle As String
Dim sTxt As String
Set Regex = CreateObject("VbsCript.Regexp")
'Mit Bereichs-Eingabe-Option
'Set Bereich = Application.InputBox("Bitte markieren Sie einen Bereich", "Bereich wählen", , , , , , 8)
'Mit fester Vorgabe ... hier Namensbereich
Set Bereich = ActiveSheet.Range("Wettspielzeitraum")
'MsgBox "Sie haben den folgenden Bereich ausgewählt: " & Bereich.AddressLocal(False, False)
On Error GoTo 0
ActiveSheet.Range(Bereich.AddressLocal(False, False)).Copy
sTitle = Application.UserName & " says:"
sTxt = InputBox(prompt:="Eingabe Suchbegriff:", Title:=sTitle)
If sTxt = "" Then Exit Sub
MsgBox sTxt
'ActiveSheet.Range("A32:H106").Copy
With Regex
.Pattern = sTxt
.Global = True
Set M = .Execute(lesen)
MsgBox M.Count
anzEinsatz = M.Count
End With
Application.CutCopyMode = False
End Sub
Function lesen()
Dim CLP As Object
On Error Resume Next
Set CLP = CreateObject("HTMLfile")
lesen = CLP.ParentWindow.ClipboardData.GetData("text")
Set CLP = Nothing
End Function
Vielleicht kann mir jemand helfen?