Sub Lister_Formules_II()
Dim ws As Worksheet, j&, formules(), rng1 As Range, rng2 As Range
j = 1
ReDim Preserve formules(1 To 50000, 1 To 3)
'si erreur remplacer 50000 par une valeur supérieure
For Each ws In ActiveWorkbook.Sheets
Set rng1 = Nothing
On Error Resume Next
Set rng1 = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rng1 Is Nothing Then
For Each rng2 In rng1
formules(j, 1) = rng1.Parent.Name
formules(j, 2) = rng2.Address(0, 0)
formules(j, 3) = "'" & CStr(rng2.FormulaLocal)
j = j + 1
Next rng2
End If
Next ws
Sheets.Add
[A1:C1] = Array("Nom feuille", "Adresse", "Formule")
[A2].Resize(UBound(formules, 1), UBound(formules, 2)) = formules
End Sub