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