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

[Jouxte]

Bonjour à toutes et tous,

Dans un classeur aux multiples onglets et aux plages nommées qui se sont multipliées au fil du temps, je souhaite faire du ménage dans ces plages nommées.
A cette fin je souhaite lister toutes les cellules dont la formule contient au moins une plage nommée.

Merci par avance pour votre aide et bonnes fêtes de fin d'année..

 

[Dranreb]

Bonjour.
Suggestion: cherchez les antécédents de la plage.

 

[Staple1600]

Bonjour le fil

Je vois un peu trop grand
(issu de mes archives)
Mais au moins, tu auras la liste de tes formules

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

 

[Dudu2]

Ou une macro du genre

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

 

[Jouxte]

Bonjour Dranreb, Staple 1600, Dudu2, le Forum,

Merci pour vos propositions, dans les 2 cas j'ai hélas un message d'erreur.
Pour Lister_Formules à la ligne :
formules(j, 1) = rng1.Parent.Name
erreur d'exécution 9 l'indice n'appartient pas à la sélection

Pour CellulesUtilisantNom à la ligne :
Rng.Select

erreur d'exécution '91'
Variable d'objet ou variable de bloc With non définie

 

[Staple1600]

Re

Jouxte
J'ai fait mon test sur un classeur vierge avec 3 feuilles et sur chaque feuille une dizainne de cellules avec des formules différentes
Essais de faire un test sur un classeur de ce type.

 

[Staple1600]

Re

Je viens de faire le test
(en utilisant le code ci-dessous pour créer mon classeur de test)

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

NB: Par défaut, ici, mon Excel crée un classeur vierge avec 3 feuilles.
Donc si vous avez un classur avec moins ou plus de 3 feuilles, il y aura bug.
Dans ce cas, utilisez cette version sur un classeur vierge avec 3 feuilles

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

Une fois le classeur de test créé, copiez y dans son projet VBA le code proposé dans le message#3

 

[Dudu2]

@Jouxte,
Le code de @Staple1600 du post #3 fonctionne bien chez moi.
Mais comme tu as probablement plus de 1000 formules dans tes feuilles, c'est normal qu'il plante en erreur 9.

 

[Dudu2]

Peut-être comme ça...

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

 

[Jouxte]

Re,

Désolé, mais le code ci-dessus me génère une erreur.
j'ai procédé comme suit :
création d'un nouveau classeur> insérer module où je colle le code ci-dessus, je lance la macro Creer_Test
erreur d'exécution '13':
Incompatibilité de type

débogage sur la ligne :
x = [ALEA.ENTRE.BORNES(1,5)]

 

[Jouxte]

Désolé Dudu, je n'avais pas vu ton post.je répondais à Staple1600

 

[Jouxte]

Re,
@Dudu2
erreur d'éxéxution '13': (sur la dernière ligne)
incompatibilité de type
[A2].Resize(UBound(formules, 2), UBound(formules, 1)) = Application.Transpose(formules)

 

[Staple1600]

Re

Jouxte
Crée alors un classeur de test manuellement avec trois feuilles sur lesquelles tu inséres des formules différentes sur des plages différentes
Mes formules exemple étaient
=ADRESSE(LIGNE();COLONNE();4)
=AUJOURDHUI()+LIGNE()
=COS(LIGNE())

=>Dudu2
Merci d'avoir améliorer mon code

 

[Jouxte]

Re,
@Staple1600 j'ai la même erreur en utilisant la procédure ci-dessus.

 

[Dudu2]

@Staple1600, avec plaisir y avait pas grand chose à faire

J'améliore le code amélioré pour ne sortir que les formules qui contiennent une référence du Gestionnaire de noms.

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