Schriftart in Word ersetzen

Sub Word_AlleVerwendetenSchriftarten()
 
 Dim doc As Document, r As Range
 Dim lAnf As Long, lEnd As Long, x As Long, y As Long
 Dim sFontName As String, sTmp As String, sfx As String, sfy As String
 Dim bGefunden As Boolean
 Dim f() As String, fCnt As Long
 
 fCnt = 0: ReDim f(1 To 1)
 
->alle Zeichen des aktiven Dokumentes auf ihren Fontnamen pruefen
->und in Liste eintragen, wenn noch nicht vorhanden
 Set doc = ActiveDocument
 lAnf = doc.Content.Start
 lEnd = doc.Content.End
 For x = lAnf To lEnd - 1
  sFontName = doc.Range(Start:=x, End:=x + 1).Font.Name
  bGefunden = False
  For y = 1 To fCnt
   If f(y) = sFontName Then bGefunden = True: Exit For
  Next
  If Not bGefunden Then
   fCnt = fCnt + 1: ReDim Preserve f(1 To fCnt): f(fCnt) = sFontName
  End If
 Next
 
->Liste Sortieren
 For x = 1 To fCnt - 1
  For y = x + 1 To fCnt
   sfx = f(x) & String(100 - Len(f(x)), Chr(32))
   sfy = f(y) & String(100 - Len(f(y)), Chr(32))
   If sfx > sfy Then sTmp = f(x): f(x) = f(y): f(y) = sTmp
  Next
 Next
 
->Meldung mit Font-Namen ausgeben
 sTmp = Folgende Schriften werden verwendet: 
 For x = 1 To fCnt: sTmp = sTmp & vbCrLf & f(x): Next
 MsgBox sTmp
 
 Set doc = Nothing: Set r = Nothing
End Sub