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

Jouxte

XLDnaute Occasionnel
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..
 

Staple1600

XLDnaute Barbatruc
Bonjour le fil

Je vois un peu trop grand ;)
(issu de mes archives)
Mais au moins, tu auras la liste de tes formules ;)
VB:
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

XLDnaute Barbatruc
Ou une macro du genre
VB:
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
 
Dernière édition:

Jouxte

XLDnaute Occasionnel
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

XLDnaute Barbatruc
Re

Je viens de faire le test
(en utilisant le code ci-dessous pour créer mon classeur de test)
VB:
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
VB:
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

XLDnaute Barbatruc
Peut-être comme ça...
VB:
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
 
Dernière édition:

Jouxte

XLDnaute Occasionnel
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)]
 

Staple1600

XLDnaute Barbatruc
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
;)
 

Dudu2

XLDnaute Barbatruc
@Staple1600, avec plaisir :) y avait pas grand chose à faire
1609257553228.gif

J'améliore le code amélioré pour ne sortir que les formules qui contiennent une référence du Gestionnaire de noms.
VB:
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
 
Dernière édition:

Discussions similaires

Haut Bas