Microsoft 365 Récupérer toutes les formules d'un classeur par feuille

Public Sub ExtractFormulas()
Dim l_as_formulas() As String
Dim l_o_wb As Excel.Workbook
   
    Set l_o_wb = ActiveWorkbook
   
    l_as_formulas = ExtractWorkbookFormulas(l_o_wb)
   
    If (Not l_as_formulas) <> -1 Then
        With Application.Workbooks.Add(xlWBATWorksheet).Worksheets(1)
            .Range("A1").Value = "Feuille"
            .Range("B1").Value = "Cellule"
            .Range("C1").Value = "Formule"
            .Range("A2").Resize(UBound(l_as_formulas, 1), UBound(l_as_formulas, 2)).Value = l_as_formulas
            .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "Tab_ListeFormules"
            .Range("A1").CurrentRegion.EntireColumn.AutoFit
        End With
    Else
        MsgBox "Aucune formule trouvée dans le classeur '" & l_o_wb.Name & "'.", vbInformation, "Info"
    End If
End Sub


Private Function ExtractWorkbookFormulas(p_o_wb As Excel.Workbook) As String()
Dim l_o_ws As Excel.Worksheet
Dim l_as_formulas() As String
Dim l_as_result() As String
Dim l_l_i As Long

    For Each l_o_ws In p_o_wb.Worksheets
        ExtractWorksheetFormulas l_o_ws, l_as_formulas
    Next l_o_ws
    If (Not l_as_formulas) <> -1 Then
        ReDim l_as_result(1 To UBound(l_as_formulas, 2), 1 To 3)
        For l_l_i = 1 To UBound(l_as_formulas, 2)
            l_as_result(l_l_i, 1) = l_as_formulas(1, l_l_i)
            l_as_result(l_l_i, 2) = l_as_formulas(2, l_l_i)
            l_as_result(l_l_i, 3) = l_as_formulas(3, l_l_i)
        Next l_l_i
    End If
    ExtractWorkbookFormulas = l_as_result
End Function

Private Sub ExtractWorksheetFormulas(p_o_ws As Excel.Worksheet, p_as_formulas() As String)
Dim l_o_rngFind As Excel.Range
Dim l_s_memAddress As String
Dim l_l_i As Long

    Set l_o_rngFind = p_o_ws.UsedRange.Find("=", , xlFormulas, xlPart)
    If Not l_o_rngFind Is Nothing Then
        l_s_memAddress = l_o_rngFind.Address
        Do
            If l_o_rngFind.HasFormula Then
                If (Not p_as_formulas) <> -1 Then
                    l_l_i = UBound(p_as_formulas, 2) + 1
                    ReDim Preserve p_as_formulas(1 To 3, 1 To l_l_i)
                Else
                    ReDim p_as_formulas(1 To 3, 1 To 1)
                    l_l_i = 1
                End If
                p_as_formulas(1, l_l_i) = p_o_ws.Name
                p_as_formulas(2, l_l_i) = l_o_rngFind.Address(False, False)
                p_as_formulas(3, l_l_i) = l_o_rngFind.Formula2Local
                Set l_o_rngFind = p_o_ws.UsedRange.FindNext(l_o_rngFind)
            End If
        Loop Until l_o_rngFind.Address Like l_s_memAddress
    End If
End Sub

Option Explicit

Public Sub ListFormulas()
Dim wb As Workbook, ws As Worksheet, wsList As Worksheet
Dim rngFormulas As Range, Cell As Range
Dim lRow As Long

    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    On Error Resume Next
    wb.Worksheets("Formules").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    Set wsList = wb.Worksheets.Add
    
    With wsList
        .Name = "Formules"
        With .Range("A1:D1")
            .Value = Array("Feuille", "Adresse", "Formule", "Valeur")
            .Font.Bold = True
        End With
    End With
    
    lRow = 2
    
    For Each ws In wb.Worksheets
        If ws.Name <> "Formules" Then
            On Error Resume Next
            Set rngFormulas = ws.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
            If Err.Number = 0 Then
                For Each Cell In rngFormulas
                    With wsList
                        .Cells(lRow, 1).Value = ws.Name
                        .Cells(lRow, 2).Value = Cell.Address(0, 0)
                        .Cells(lRow, 3).Value = " " & Cell.Formula
                        .Cells(lRow, 4).Value = Cell.Value
                        lRow = lRow + 1
                    End With
                Next Cell
            End If
            On Error GoTo 0
        End If
    Next ws
    
    wsList.Range("A1:D1").EntireColumn.AutoFit
    
End Sub