Sub Finden()
vTextFN = "Müller"
s = -1
With Selection.Find
.Text = vTextFN
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
Do While .Found And .Parent.Start >= s
If Not InQuotes(.Parent.Range) Then
If s = -1 Then s = .Parent.Start
t = Timer
Do: Loop Until Timer >= t + 2
End If
.Execute
DoEvents
Loop
End With
End Sub
Function InQuotes(rng As Range) As Boolean
Dim drng As Range, t As String
Set drng = ActiveDocument.Range
Dim a As Long, a1 As Long, a2 As Long, a3 As Long, b As Long, b1 As Long, b2 As Long, b3 As Long, x As Byte
a1 = InStrRev(drng.Text, Chr(34), rng.Start + 1)
a2 = InStrRev(drng.Text, Chr(132), rng.Start + 1)
a3 = InStrRev(drng.Text, Chr(147), rng.Start + 1)
a = IIf(a2 > a1, a2, a1)
a = IIf(a3 > a, 0, a)
b1 = InStr(rng.Start + 1, drng.Text, Chr(34))
b2 = InStr(rng.Start + 1, drng.Text, Chr(147))
b3 = InStr(rng.Start + 1, drng.Text, Chr(132))
b = IIf(b2 < b1 And b2 > 0 Or b1 = 0, b2, b1)
b = IIf(b3 < b And b3 > 0, 0, b)
If a > 0 Then
t = drng.Characters(a).Next
If t <> " " And t <> Chr(13) And t <> Chr(10) Then x = x + 1
End If
If b > 0 Then
t = drng.Characters(b).Previous
If t <> " " And t <> Chr(13) And t <> Chr(10) Then x = x + 1
End If
InQuotes = x = 2
End Function