Sub ChangeListFonts()
  Dim aLT As ListTemplate, aLL As ListLevel
  For Each aLT In ActiveDocument.ListTemplates
    For Each aLL In aLT.ListLevels
      If aLL.Index <> 3 Then
        aLL.Font.Name = "Times New Roman"
      End If
    Next aLL
  Next aLT
End Sub