XL 2013 lister toutes les cellules dont la formule contient au moins une plage nommée

Sub Lister_Formules()
Dim ws As Worksheet, j&, formules(), rng1 As Range, rng2 As Range
j = 1
ReDim Preserve formules(1 To 1000, 1 To 3)
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

Sub CellulesUtilisantNom()
    Dim Rng As Range
  
    Set Rng = ChercheNomEnFormules("Tableau1")
    Rng.Select
End Sub

Function ChercheNomEnFormules(Nom As String) As Range
    Dim Cellule As Range
    Dim Rng As Range
  
    For Each Cellule In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas)
        If InStr(Cellule.FormulaLocal, Nom) Then
            If Rng Is Nothing Then Set Rng = Cellule Else Set Rng = Union(Rng, Cellule)
        End If
    Next Cellule
  
    Set ChercheNomEnFormules = Rng
End Function

Option Explicit
Option Base 1
Sub Creer_Test()
Dim wbk As Workbook, x&, y&, z%, formules, ws As Worksheet
formules = Array("=ADDRESS(ROW(),COLUMN(),4)", "=TODAY()+ROW()", "=COS(ROW())")
Workbooks.Add
Randomize
Set wbk = ActiveWorkbook
For Each ws In wbk.Worksheets
x = [ALEA.ENTRE.BORNES(1,5)]
z = ws.Index
ws.Cells(x).Resize([ALEA.ENTRE.BORNES(7,21)]) = formules(z)
Next
End Sub

Option Explicit
Option Base 1
Sub Creer_Test_B()
Dim wbk As Workbook, x&, y&, z%, formules, ws As Worksheet
formules = Array("=ADDRESS(ROW(),COLUMN(),4)", "=TODAY()+ROW()", "=COS(ROW())")
Randomize
Set wbk = ActiveWorkbook
'Le classeur actif doit contenir uniquement 3 feuilles
For Each ws In wbk.Worksheets
x = [ALEA.ENTRE.BORNES(1,5)]
z = ws.Index
ws.Cells(x).Resize([ALEA.ENTRE.BORNES(7,21)]) = formules(z)
Next
End Sub

Sub Lister_Formules()
    Dim ws As Worksheet, j&, formules(), rng1 As Range, rng2 As Range
    j = 1
    ReDim formules(1 To 3, 1 To j)
    formules(1, j) = "Nom feuille"
    formules(2, j) = "Adresse"
    formules(3, j) = "Formule"

    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
                If rng2.MergeArea(1).Address = rng2.Address Then
                    j = j + 1
                    ReDim Preserve formules(1 To 3, 1 To j)
                    formules(1, j) = rng1.Parent.Name
                    formules(2, j) = rng2.Address(0, 0)
                    formules(3, j) = "'" & CStr(rng2.FormulaLocal)
                End If
            Next rng2
        End If
    Next ws
    Sheets.Add
    '[A1:C1] = Array("Nom feuille", "Adresse", "Formule")
    [A2].Resize(UBound(formules, 2), UBound(formules, 1)) = Application.Transpose(formules)
End Sub

Sub Lister_Formules()
    Dim ws As Worksheet, j&, k&, p&, formules(), rng1 As Range, rng2 As Range
    Dim TabNoms() As String
  
    If ThisWorkbook.Names.Count > 0 Then
        ReDim TabNoms(1 To ThisWorkbook.Names.Count)
        For k = 1 To ThisWorkbook.Names.Count
            TabNoms(k) = ThisWorkbook.Names(k).Name
        Next k
        p = UBound(TabNoms)
    End If
  
    For Each ws In ActiveWorkbook.Sheets
        If ws.ListObjects.Count > 0 Then
            ReDim Preserve TabNoms(1 To p + ws.ListObjects.Count)
            For k = 1 To ws.ListObjects.Count
                TabNoms(p + k) = ws.ListObjects(k).Name
            Next k
            p = UBound(TabNoms)
        End If
    Next ws
  
    j = 1
    ReDim formules(1 To 3, 1 To j)
    formules(1, j) = "Nom feuille"
    formules(2, j) = "Adresse"
    formules(3, j) = "Formule avec nom"

    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
                If rng2.MergeArea(1).Address = rng2.Address Then
                    For k = 1 To p
                        If InStr(rng2.FormulaLocal, TabNoms(k)) > 0 Then Exit For
                    Next k
                    If k <= p Then
                        j = j + 1
                        ReDim Preserve formules(1 To 3, 1 To j)
                        formules(1, j) = rng1.Parent.Name
                        formules(2, j) = rng2.Address(0, 0)
                        formules(3, j) = "'" & CStr(rng2.FormulaLocal)
                    End If
                End If
            Next rng2
        End If
    Next ws
    Sheets.Add
    '[A1:C1] = Array("Nom feuille", "Adresse", "Formule")
    [A2].Resize(UBound(formules, 2), UBound(formules, 1)).Value = Application.Transpose(formules)
End Sub