Это не тривиальная проблема.Но это было решено уже в 2014 году.
(см. https://colinlegg.wordpress.com/2014/01/14/vba-determine-all-precedent-cells-a-nice-example-of-recursion/)
. Ниже приведен приведенный выше код, измененный для отображения запрошенного списка:
Все ссылки на листы:
[ Sheet: Sheet1 - 0 ]
[ Sheet: Sheet1 - 1 ]
[ Sheet: Sheet2 - 2 ]
[ Sheet: Sheet2 - 3 ]
[ Sheet: Sheet11 - 4 ]
[ Sheet: Sheet11 - 5 ]
[ Sheet: Old_Sheet11 - 6 ]
[ Sheet: Old_Sheet11 - 7 ]
[ Sheet: Sheet4 - 8 ]
[ Sheet: Sheet6 - 9 ]
Ваш запрошенный список:
Sheet1
Sheet2
Sheet11
Old_Sheet11
Sheet4
Sheet6
А вот модифицированный код:
Option Explicit
'see https://colinlegg.wordpress.com/2014/01/14/vba-determine-all-precedent-cells-a-nice-example-of-recursion/
Sub Test2()
Dim rngToCheck As Range
Dim dicAllPrecedents As Object
Dim dicPrecedents As Object
Dim dicSheets As Object
Dim i As Long
Dim resultRange As Range
Dim actSheetName As String
Dim SheetNr As Integer
Set rngToCheck = Sheet1.Range("A1:A5")
Set dicAllPrecedents = GetAllPrecedents(rngToCheck)
'The ORIGINAL displays the full address of the precendents
'=========================================================
'
' Debug.Print "==="
'If dicAllPrecedents.Count = 0 Then
' Debug.Print rngToCheck.Address(External:=True); " has no precedent cells."
'Else
' For i = LBound(dicAllPrecedents.Keys) To UBound(dicAllPrecedents.Keys)
' Debug.Print "[ Level:"; dicAllPrecedents.Items()(i); "]";
' Debug.Print "[ Address: "; dicAllPrecedents.Keys()(i); " ]"
' Next i
'End If
'Debug.Print "==="
'List all sheets
If dicAllPrecedents.Count = 0 Then
Debug.Print rngToCheck.Address(External:=True); " has no precedent cells."
Else
For i = LBound(dicAllPrecedents.keys) To UBound(dicAllPrecedents.keys)
'Debug.Print "[ Level:"; dicAllPrecedents.Items()(i); "]";
Set resultRange = Range(dicAllPrecedents.keys()(i))
Debug.Print "[ Sheet: "; resultRange.Parent.Name; " - "; i; " ]"
Next i
End If
Debug.Print "==="
'LIST EACH SHEET ONLY ONCE
'=========================
'
Set dicSheets = CreateObject("Scripting.Dictionary")
SheetNr = 0
For i = LBound(dicAllPrecedents.keys) To UBound(dicAllPrecedents.keys)
Set resultRange = Range(dicAllPrecedents.keys()(i))
actSheetName = resultRange.Parent.Name
If Not dicSheets.Exists(actSheetName) Then
SheetNr = SheetNr + 1
dicSheets.Add actSheetName, SheetNr
End If
Next i
For i = LBound(dicSheets.keys) To UBound(dicSheets.keys)
Debug.Print dicSheets.keys()(i)
Next i
End Sub
'won't navigate through precedents in closed workbooks
'won't navigate through precedents in protected worksheets
'won't identify precedents on hidden sheets
Public Function GetAllPrecedents(ByRef rngToCheck As Range) As Object
Const lngTOP_LEVEL As Long = 1
Dim dicAllPrecedents As Object
Dim strKey As String
Set dicAllPrecedents = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
GetPrecedents rngToCheck, dicAllPrecedents, lngTOP_LEVEL
Set GetAllPrecedents = dicAllPrecedents
Application.ScreenUpdating = True
End Function
Private Sub GetPrecedents(ByRef rngToCheck As Range, ByRef dicAllPrecedents As Object, ByVal lngLevel As Long)
Dim rngCell As Range
Dim rngFormulas As Range
If Not rngToCheck.Worksheet.ProtectContents Then
If rngToCheck.Cells.CountLarge > 1 Then 'Change to .Count in XL 2003 or earlier
On Error Resume Next
Set rngFormulas = rngToCheck.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
Else
If rngToCheck.HasFormula Then Set rngFormulas = rngToCheck
End If
If Not rngFormulas Is Nothing Then
For Each rngCell In rngFormulas.Cells
GetCellPrecedents rngCell, dicAllPrecedents, lngLevel
Next rngCell
rngFormulas.Worksheet.ClearArrows
End If
End If
End Sub
Private Sub GetCellPrecedents(ByRef rngCell As Range, ByRef dicAllPrecedents As Object, ByVal lngLevel As Long)
Dim lngArrow As Long
Dim lngLink As Long
Dim blnNewArrow As Boolean
Dim strPrecedentAddress As String
Dim rngPrecedentRange As Range
Do
lngArrow = lngArrow + 1
blnNewArrow = True
lngLink = 0
Do
lngLink = lngLink + 1
rngCell.ShowPrecedents
On Error Resume Next
Set rngPrecedentRange = rngCell.NavigateArrow(True, lngArrow, lngLink)
If Err.Number <> 0 Then
Exit Do
End If
On Error GoTo 0
strPrecedentAddress = rngPrecedentRange.Address(False, False, xlA1, True)
If strPrecedentAddress = rngCell.Address(False, False, xlA1, True) Then
Exit Do
Else
blnNewArrow = False
If Not dicAllPrecedents.Exists(strPrecedentAddress) Then
dicAllPrecedents.Add strPrecedentAddress, lngLevel
GetPrecedents rngPrecedentRange, dicAllPrecedents, lngLevel + 1
End If
End If
Loop
If blnNewArrow Then Exit Do
Loop
End Sub