Sub Authors()
'Format all surnames (found according to their specific signs) in the selected range.

Dim rng As range
    Application.ScreenUpdating = False
    Set rng = selection.range
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = "[Vv]gl. @<[A-Z][!A-Z][a-z]@>"
        .Forward = True
        .MatchWildcards = True
        .Wrap = wdFindStop
        While .Execute
            rng.MoveStartUntil cset:=" "
            rng.Font.Italic = True
            rng.Font.AllCaps = True
            rng.Collapse wdCollapseEnd
        Wend
    End With
    Application.ScreenUpdating = True
    Set rng = Nothing
 End Sub

Sub FormatAuthorNamesInSmallCaps()

Dim rng As Range
Dim authorNames As Variant
Dim footnote As Footnote

Application.ScreenUpdating = False
    Set rng = ActiveDocument.Range

    'Liste der Autorennamen
    authorNames = Array("Ackermann", "Angermann", _
    "Andersen", "Atzeni", "Baecker", "Ortmann", _
    "Zamoyski", "Ziegler", "Wurzbach", "Zittel", _
    "Zürcher", "Zytphen-Adeler")

    ' Formatierung im Haupttextkörper
    For i = 0 To UBound(authorNames)
        Call FormatRange(rng, authorNames(i))
    Next i

    ' Formatierung in den Fußnoten
    For Each footnote In ActiveDocument.Footnotes
        Set rng = footnote.Range
        For i = 0 To UBound(authorNames)
            Call FormatRange(rng, authorNames(i))
        Next i
    Next footnote

Application.ScreenUpdating = True
End Sub

' Hilfsfunktion zur Formatierung eines Bereichs
Sub FormatRange(ByRef rng As Range, ByVal searchText As String)
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = searchText
        .Forward = True
        .Wrap = wdFindStop
        .MatchWholeWord = True
        While .Execute
            rng.Font.Italic = True
            rng.Font.SmallCaps = True
            rng.Collapse wdCollapseEnd
        Wend
    End With
End Sub

Sub Authors()
'Format all surnames (found according to their specific signs) in the whole doc
'(all story ranges).

Dim myStoryRng As range
Dim rng As range

    Application.ScreenUpdating = False
    For Each myStoryRng In ActiveDocument.StoryRanges
        Set rng = myStoryRng
        With rng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .text = "[Vv]gl. @<[A-Z][!A-Z][a-z]@>"
            .Forward = True
            .MatchWildcards = True
            .Wrap = wdFindStop
            While .Execute
                rng.MoveStartUntil cset:=" "
                rng.Font.Italic = True
                rng.Font.AllCaps = True
                rng.Collapse wdCollapseEnd
            Wend
        End With
    Next myStoryRng
    Application.ScreenUpdating = True
    Set rng = Nothing
 End Sub