Identifier les dépendants contenus sur d'autres feuilles

**SilkyRoad** · 25/08/2007, 21h24

bonsoir

La propriété d'identification des dépendants fonctionne uniquement sur la feuille active et ne peut pas suivre les références distantes (sur les autres feuilles).
La procédure suivante recherche les dépendants d'une cellule dans toutes les feuilles du classeur.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
Option Explicit
 
Sub Test()
    'Liste les dépendants de la cellule D4, dans la Feuil2
    ListeDependents Worksheets("Feuil2").Range("D4")
End Sub
 
 
Sub ListeDependents(Cellule As Range)
    Dim Ws As Worksheet
    Dim Plage As Range, Cell As Range, DirectDep As Range
    Dim i As Integer, x As Integer
    Dim Cible As String, strDepenDent As String, strRefer As String
    'La liste des dépendants  va être stockée dans une collection
    Dim Un As New Collection
 
 
    'Active la feuille contenant la cellule à contrôler
    Cellule.Parent.Activate
 
    strDepenDent = Cellule.Parent.Name & "!" & Cellule.Address(0, 0)
 
 
    'Vérifie s'il y a des dépendants directs dans la feuille:
    On Error Resume Next
    'Définit la plage de cellules dépendantes, dans la feuille active
    Set Plage = Cellule.DirectDependents.Cells
    On Error GoTo 0
 
    If Not Plage Is Nothing Then
        'Boucle sur les dépendants contenus dans la feuille active
        For Each DirectDep In Cellule.DirectDependents.Cells
            Un.Add Cellule.Parent.Name & "!" & DirectDep.Address, _
                Cellule.Parent.Name & "!" & DirectDep.Address
        Next DirectDep
    End If
 
    Set Plage = Nothing
 
 
 
    'Boucle sur les autres feuilles du classeur:
    For Each Ws In ThisWorkbook.Worksheets
        'Si la feuille est différente de la feuille active
        If Ws.Name <> Cellule.Parent.Name Then
 
            On Error Resume Next
            'Définit la plage de cellules contenant des formules
            Set Plage = Ws.UsedRange.SpecialCells(xlCellTypeFormulas)
            On Error GoTo 0
 
 
            'Vérifie si la feuille contient des formules
            If Not Plage Is Nothing Then
 
                'Boucle sur les cellules contenant des formules
                For Each Cell In Plage
 
                    'Gestion des références relatives et absolues
                    Cible = Replace(Cell.Formula, "$", "")
 
 
                    'Vérifie si le nom de la feuille apparait dans la formule.
                    If InStr(1, Cible, Cellule.Parent.Name) > 0 Then
 
                        'Vérifie si la formule contient une référence correspondant à la
                        'cellule à contrôler
                        i = 0
                        i = InStr(1, Cible, strDepenDent)
 
                        'Si la référence est trouvée on l'intègre dans la collection
                        If i > 0 And Not IsNumeric(Mid(Cible, i + Len(strDepenDent), 1)) Then
 
                            Un.Add Ws.Name & "!" & Cell.Address, Ws.Name & "!" & Cell.Address
 
                        Else
 
                            'Recherche des références dans les plages de cellules
                            For x = 1 To Len(Cible)
                                i = 0
                                i = InStr(1, Cible, ":")
 
                                If i > 0 Then
                                    strRefer = ExtractionReferences(Cible)
 
                                    'Si la cellule à contrôler se trouve dans la plage,
                                    'on l'intègre dans la collection.
                                    If VerifIntersect(Cellule, Range(strRefer)) And _
                                        InStr(1, Cible, Cellule.Parent.Name & "!" & strRefer) > 0 Then
 
                                        On Error Resume Next
                                        Un.Add Ws.Name & "!" & Cell.Address, Ws.Name & "!" & Cell.Address
                                        On Error GoTo 0
 
                                        Exit For
                                    End If
 
                                    Cible = Mid(Cible, i + 1)
                                Else
                                    Exit For
                                End If
                            Next x
                            '--------------
 
 
                        End If
                    End If
                Next Cell
 
            End If
        End If
 
        Set Plage = Nothing
    Next Ws
 
 
    'Boucle sur la collection qui contient la liste des dépendants
    For i = 1 To Un.Count
        'Affiche le résultat dans la fenêtre d'exécution (Ctrl+G)
        Debug.Print Un.Item(i)
    Next i
End Sub
 
 
 
 
'Extrait les références spécifiées dans les formules
Function ExtractionReferences(Chaine As String) As String
    Dim i As Integer, j As Integer
    Dim strPlage As String, Caract As String
 
    i = InStr(1, Chaine, ":")
 
 
    'Renvoie la référence avant les deux points ":"
    For j = i - 1 To 1 Step -1
        Caract = Mid(Chaine, j, 1)
 
        Select Case Asc(Caract)
            Case 48 To 57, 65 To 90, 97 To 122
            strPlage = Caract & strPlage
            Case Else: Exit For
        End Select
    Next j
 
    strPlage = strPlage & ":"
 
    'Renvoie la référence après les deux points ":"
    For j = i + 1 To Len(Chaine)
        Caract = Mid(Chaine, j, 1)
 
        Select Case Asc(Caract)
            Case 48 To 57, 65 To 90, 97 To 122
            strPlage = strPlage & Caract
            Case Else: Exit For
        End Select
    Next j
 
    ExtractionReferences = strPlage
End Function
 
 
 
'Vérifie si la référence extraite dans la formule a une intersection
'avec la cellule dont on contrôle les dépendances.
Function VerifIntersect(objDepend As Range, objReference As Range) As Boolean
    Dim objRange As Range
 
    Set objRange = Intersect(objDepend, objReference)
 
    If objRange Is Nothing Then
        VerifIntersect = False
        Else
        VerifIntersect = True
    End If
End Function

bonne soirée
michel

**danipron** · 18/05/2013, 18h15

Hello !

Trouvé sur le support Microsoft une solution sans code VBA

"Pour sélectionner la cellule à l’autre extrémité de la flèche, double-cliquez sur la flèche.
Si la cellule se trouve dans une autre feuille de calcul ou un autre classeur, double-cliquez sur la flèche noire pour afficher la boîte de dialogue Atteindre, puis sur la référence souhaitée dans la liste Atteindre. "

Nom : 18-05-2013 17-46-31.png
Affichages : 13134
Taille : 26,1 Ko

Nom : 18-05-2013 17-46-31.png
Affichages : 13134
Taille : 26,1 Ko

**francis60** · 03/11/2015, 13h33

Bonjour,

Je vous propose une adaptation du code de SilkyRoad qui permet d'identifier les dépendants de chaque cellule de la sélection courante utilisable depuis un classeur distinct et qui ajoute les formules sources en sortie.

Attention:

Si une plage nommée est utilisée, la dépendance ne sera pas reconnue.

Les noms d'onglets ne doivent pas comporter d'espace sinon Excel ajoute des guillemets simples autour de ces noms dans les formules et ils ne sont alors plus reconnus.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
Option Explicit
 
Sub Test()
Dim c As Range                          '<< Adaptation du code de SilkyRoad
                                        '<< Adaptation du code de SilkyRoad     'Liste les dépendants de la selection
    For Each c In Selection.Cells       '<< Adaptation du code de SilkyRoad
        ListeDependents c               '<< Adaptation du code de SilkyRoad
        Next                            '<< Adaptation du code de SilkyRoad
 
End Sub
 
 
Sub ListeDependents(Cellule As Range)
    Dim Ws As Worksheet
    Dim Plage As Range, Cell As Range, DirectDep As Range
    Dim i As Integer, x As Integer
    Dim Cible As String, strDepenDent As String, strRefer As String
    'La liste des dépendants  va être stockée dans une collection
    Dim Un As New Collection
 
 
    'Active la feuille contenant la cellule à contrôler
    Cellule.Parent.Activate
 
    strDepenDent = Cellule.Parent.Name & "!" & Cellule.Address(0, 0)
 
 
    'Vérifie s'il y a des dépendants directs dans la feuille:
    On Error Resume Next
    'Définit la plage de cellules dépendantes, dans la feuille active
    Set Plage = Cellule.DirectDependents.Cells
    On Error GoTo 0
 
    If Not Plage Is Nothing Then
        'Boucle sur les dépendants contenus dans la feuille active
        For Each DirectDep In Cellule.DirectDependents.Cells
            Un.Add Cellule.Parent.Name & "!" & DirectDep.Address & " > " & DirectDep.Formula, _
                Cellule.Parent.Name & "!" & DirectDep.Address & " > " & DirectDep.Formula '<< Adaptation du code de SilkyRoad (Formule ajoutée)
        Next DirectDep
    End If
 
    Set Plage = Nothing
 
 
 
    'Boucle sur les autres feuilles du classeur:
    For Each Ws In ActiveWorkbook.Worksheets    '<< Adaptation du code de SilkyRoad (ThisWorkbook devient ActiveWorkbook)
        'Si la feuille est différente de la feuille active
        If Ws.Name <> Cellule.Parent.Name Then
 
            On Error Resume Next
            'Définit la plage de cellules contenant des formules
            Set Plage = Ws.UsedRange.SpecialCells(xlCellTypeFormulas)
            On Error GoTo 0
 
 
            'Vérifie si la feuille contient des formules
            If Not Plage Is Nothing Then
 
                'Boucle sur les cellules contenant des formules
                For Each Cell In Plage
 
                    'Gestion des références relatives et absolues
                    Cible = Replace(Cell.Formula, "$", "")
 
 
                    'Vérifie si le nom de la feuille apparait dans la formule.
                    If InStr(1, Cible, Cellule.Parent.Name) > 0 Then
 
                        'Vérifie si la formule contient une référence correspondant à la
                        'cellule à contrôler
                        i = 0
                        i = InStr(1, Cible, strDepenDent)
 
                        'Si la référence est trouvée on l'intègre dans la collection
                        If i > 0 And Not IsNumeric(Mid(Cible, i + Len(strDepenDent), 1)) Then
 
                            Un.Add Ws.Name & "!" & Cell.Address & " > " & Cell.Formula, Ws.Name & "!" & Cell.Address & " > " & Cell.Formula     '<< Adaptation du code de SilkyRoad (Formule ajoutée)
 
                        Else
 
                            'Recherche des références dans les plages de cellules
                            For x = 1 To Len(Cible)
                                i = 0
                                i = InStr(1, Cible, ":")
 
                                If i > 0 Then
                                    strRefer = ExtractionReferences(Cible)
 
                                    'Si la cellule à contrôler se trouve dans la plage,
                                    'on l'intègre dans la collection.
                                    If VerifIntersect(Cellule, Range(strRefer)) And _
                                        InStr(1, Cible, Cellule.Parent.Name & "!" & strRefer) > 0 Then
 
                                        On Error Resume Next
                                        Un.Add Ws.Name & "!" & Cell.Address & " > " & Cell.Formula, Ws.Name & "!" & Cell.Address & " > " & Cell.Formula     '<< Adaptation du code de SilkyRoad (Formule ajoutée)
                                        On Error GoTo 0
 
                                        Exit For
                                    End If
 
                                    Cible = Mid(Cible, i + 1)
                                Else
                                    Exit For
                                End If
                            Next x
                            '--------------
 
 
                        End If
                    End If
                Next Cell
 
            End If
        End If
 
        Set Plage = Nothing
    Next Ws
 
 
    'Boucle sur la collection qui contient la liste des dépendants
    For i = 1 To Un.Count
        'Affiche le résultat dans la fenêtre d'exécution (Ctrl+G)
        Debug.Print Un.Item(i)
    Next i
End Sub
 
 
 
 
'Extrait les références spécifiées dans les formules
Function ExtractionReferences(Chaine As String) As String
    Dim i As Integer, j As Integer
    Dim strPlage As String, Caract As String
 
    i = InStr(1, Chaine, ":")
 
 
    'Renvoie la référence avant les deux points ":"
    For j = i - 1 To 1 Step -1
        Caract = Mid(Chaine, j, 1)
 
        Select Case Asc(Caract)
            Case 48 To 57, 65 To 90, 97 To 122
            strPlage = Caract & strPlage
            Case Else: Exit For
        End Select
    Next j
 
    strPlage = strPlage & ":"
 
    'Renvoie la référence après les deux points ":"
    For j = i + 1 To Len(Chaine)
        Caract = Mid(Chaine, j, 1)
 
        Select Case Asc(Caract)
            Case 48 To 57, 65 To 90, 97 To 122
            strPlage = strPlage & Caract
            Case Else: Exit For
        End Select
    Next j
 
    ExtractionReferences = strPlage
End Function
 
 
 
'Vérifie si la référence extraite dans la formule a une intersection
'avec la cellule dont on contrôle les dépendances.
Function VerifIntersect(objDepend As Range, objReference As Range) As Boolean
    Dim objRange As Range
 
    Set objRange = Intersect(objDepend, objReference)
 
    If objRange Is Nothing Then
        VerifIntersect = False
        Else
        VerifIntersect = True
    End If
End Function

Cordialement,
Francis

Identifier les dépendants contenus sur d'autres feuilles

Contribuez

Discussions similaires

Partager

Partager