Sub FormatAuthorNamesInSmallCaps()

Dim rng As range
Dim authorNames As Variant

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

    For i = 0 To UBound(authorNames)
        With rng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .text = authorNames(i)
            .Forward = True
            .Wrap = wdFindStop
            .MatchWholeWord = True
            While .Execute
                rng.Font.Italic = True
                rng.Font.SmallCaps = True
                rng.Collapse wdCollapseEnd
            Wend
        End With
    Next i
Application.ScreenUpdating = True
End Sub