Est il possible de connaître toutes les polices utilisées dans un classeur ?

Il y a plusieurs solutions. Envoici quelques unes de différents auteurs :

sub listePolices() 'Laurent Longre MPFE
 Dim Arr, i As Integer
 Application.ScreenUpdating = False
 Workbooks.Add
 With Application.CommandBars.FindControl(ID:\=1728)
  ReDim Arr(1 To .ListCount, 1 To 1)
  For i = 1 To UBound(Arr)
   Arr(i, 1) = .List(i)
   Cells(i, 2).Font.Name = Arr(i, 1)
  Next i
 End With
 With Range("A1").Resize(i - 1)
  .Value = Arr
  .Offset(0, 1) = "Gloire à Toi, ô Immortelle Zaza !"
 End With
 Columns("A:B").AutoFit
 end sub

Utilise le code ci-dessous, à recopier dans un module standard. Seules les feuilles de calcul sont examinées. Si tu veux inclure les polices d'éventuelles feuilles graphiques, il faudra adapter

sub test() 'Frédéric Sigonneau MPFE
 PolicesUtilisees ActiveWorkbook
 end sub

sub PolicesUtilisees(Wbk As Workbook)
 Dim cell As Range, coll As New Collection
 Dim Sht As Worksheet, Msg$, i&
 
 For Each Sht In Wbk.Worksheets
 For Each cell In Sht.UsedRange
 If Not IsEmpty(cell) Then
 'Au cas où plusieurs polices dans la même cellule
 For i = 1 To cell.Characters.Count
 On Error Resume Next
 coll.Add cell.Characters(i, 1).Font.Name, _
 cell.Characters(i, 1).Font.Name
 On Error GoTo 0
 Next i
 End If
 Next cell
 Next Sht
 
 Msg = "Polices utilisées dans '" & Wbk.Name & "' : " & vbLf & vbLf
 For i = 1 To coll.Count
 Msg = Msg & coll(i) & vbLf
 Next i
 
 MsgBox Msg, , "Polices de caractères"
 end sub

Tu trouveras la police utilisée dans la barre d'outils standard (le menu déroulant police) en sélectionnant le caractère en question.
Ou, pour éviter de te balader dans toutes les cellules de ta feuille :

sub Roxane() 'ChrisV
 
 For Each cell In ActiveSheet.UsedRange
     If Not IsEmpty(cell) Then
 
      MsgBox cell.Font.Name
     End If
   Next
 MsgBox "Y'en à plus..."
 end sub

Mais s'il y a plusieurs polices dans la même cellule, ça plante... Alors une soluce encore plus complète :

sub Roxane_modif()
   For Each cell In ActiveSheet.UsedRange
     If Not IsEmpty(cell) Then
      cell.Select
        'On explore chaque caractère un par un
        For i = 1 To Len(cell.Value)
     'On garde une trace de l'ancienne couleur de caractère
   a = cell.Characters(i, 1).Font.Color
    'On colorie en rouge le caractère courant...pour ne pas se perdre...
  cell.Characters(i, 1).Font.Color = 255
          MsgBox cell.Characters(i, 1).Font.Name
          cell.Characters(i,
 1).Font.Color = a
        Next i
     End If
   Next
 MsgBox
 "Y'en à plus..."
 end sub