Option
Explicit
Sub
TrouveLiensExternesValidation()
Dim
rgeCell
As
Range
Dim
sDvForm
As
String
Dim
counter
As
Integer
Dim
wksResult
As
Worksheet
Dim
wks
As
Worksheet
Dim
arrNomFeuille
As
Variant
Dim
arrAdresseCellule
As
Variant
Dim
arrFormule
As
Variant
ReDim
arrNomFeuille(1
To
1)
As
Variant
ReDim
arrAdresseCellule(1
To
1)
As
Variant
ReDim
arrFormule(1
To
1)
As
Variant
Dim
arrResult
As
Variant
Dim
lRow
As
Long
Dim
lRowResultat
As
Long
Application.ScreenUpdating =
False
lRow = 1
For
Each
wks
In
ActiveWorkbook.Worksheets
wks.Visible = xlSheetVisible
For
Each
rgeCell
In
wks.UsedRange.Cells
On
Error
Resume
Next
sDvForm =
""
sDvForm = rgeCell.Validation.Formula1
On
Error
GoTo
0
If
InStr(1, sDvForm,
".xl"
) > 0
Then
lRow = lRow + 1
ReDim
Preserve
arrNomFeuille(1
To
lRow)
As
Variant
ReDim
Preserve
arrAdresseCellule(1
To
lRow)
As
Variant
ReDim
Preserve
arrFormule(1
To
lRow)
As
Variant
arrNomFeuille(lRow) = wks.Name
arrAdresseCellule(lRow) = rgeCell.Address
arrFormule(lRow) =
"'"
& sDvForm
End
If
Next
rgeCell
Next
wks
If
lRow <> 0
Then
Set
wksResult = ActiveWorkbook.Sheets.Add(before:=ThisWorkbook.Sheets(1))
ReDim
arrResult(1
To
lRow, 1
To
3)
As
Variant
arrResult(1, 1) =
"Nom de la feuille"
arrResult(1, 2) =
"Adresse de la cellule"
arrResult(1, 3) =
"Formule"
For
lRowResultat = 2
To
UBound(arrNomFeuille, 1)
arrResult(lRowResultat, 1) = arrNomFeuille(lRowResultat)
arrResult(lRowResultat, 2) = arrAdresseCellule(lRowResultat)
arrResult(lRowResultat, 3) = arrFormule(lRowResultat)
Next
lRowResultat
wksResult.Range(
"A1:C"
& UBound(arrResult, 1)).Value = arrResult
End
If
Application.ScreenUpdating =
True
End
Sub