Something like this:
Sub FindAllFonts()
Dim lngFontIndex As Long
Dim strName As String
Dim strReturn As String
Dim oOutputDoc As Document
Dim oRng As Word.Range
Dim oCol As New Collection
Dim lngIndex As Long
Application.ScreenUpdating = False
For lngFontIndex = 1 To FontNames.Count
strName = FontNames(lngFontIndex)
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Text = ""
.ClearFormatting
.Font.Name = strName
.Forward = True
.Format = True
.Wrap = wdFindStop
While .Execute
oRng.Select
On Error Resume Next
If oRng.Font.Size = 9999999 Then
For Each oChr In oRng.Characters
oCol.Add strName & " - " & oRng.Font.Size, strName & " - " & oRng.Font.Size
Next oChr
Else
oCol.Add strName & " - " & oRng.Font.Size, strName & " - " & oRng.Font.Size
End If
On Error GoTo 0
oRng.Collapse wdCollapseEnd
If oRng.End + 1 = ActiveDocument.Range.End Then GoTo NextFont
Wend
End With
NextFont:
Next lngFontIndex
Output:
For lngIndex = 1 To oCol.Count
strReturn = strReturn & oCol(lngIndex) & vbCr
Next lngIndex
Set oOutputDoc = Documents.Add
oOutputDoc.Range.Text = strReturn
Application.ScreenUpdating = True
End Sub