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 |
25/08/2007, 21h24
michel Tanguy
Identifier les dépendants contenus sur d'autres feuilles
00
