Sub FindAllFonts()      
    Dim lWhichFont As Long      
    Dim sTempName As String      
    Dim sBuffer As String      
    Dim newDoc As Document Dim p As Long      
    Application.ScreenUpdating = False      
    For lWhichFont = 1 To FontNames.Count          
        sTempName = FontNames(lWhichFont)          
        If sTempName <> "Arial" Then              
            p = FindThisFont(sTempName)              
            If p > 0 Then sBuffer = sBuffer & sTempName & " on page " & p & vbCrLf
        End If 
    End If 
Next lWhichFont 
Set newDoc = Documents.Add  
Selection.TypeText Text:=sBuffer 
Application.ScreenUpdating = True  
End Sub 
 
Function FindThisFont(sName As String) As Long      
    Selection.HomeKey Unit:=wdStory      
    With Selection.Find          
        .Text = ""          
        .ClearFormatting         
        .Font.Name = sName          
        .Forward = True          
        .Format = True 
        If .Execute Then FindThisFont = Selection.Information(wdActiveEndPageNumber)          
    End If      
End With  
End Function