List name for sheets being used in the formula of a specific sheet with the same workbook

Question

I am trying to write up a VBA function to get a list of name for sheets being used in the formula of a specific sheet.

Do you have any idea how to do so? Trying to use search function but seems it will mix up Old_Sheet11 and Sheet11.

Example:

1. Sumifs(Sheet1!B:B,Sheet1!A:A,a1)
2. Sumifs(Sheet2!B:B,Sheet2!A:A,a1)
3. Sumifs(Sheet11!B:B,Sheet11!A:A,a1)
4. Sumifs(Old_Sheet11!B:B,Old_Sheet11!A:A,a1)
5. Sum(Sheet4!a5,Sheet6!a5)

List:

1. Sheet1
2. Sheet2
3. Sheet11
4. Old_Sheet11
5. Sheet4
6. Sheet6

Thanks.

Eric

Answer 1

This is not a trivial problem. But it was solved already back in 2014.
(see https://colinlegg.wordpress.com/2014/01/14/vba-determine-all-precedent-cells-a-nice-example-of-recursion/)

Find below the above code modified to spill out the requested list:

All Sheet references:

[ 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  ]

Your requested List:

Sheet1
Sheet2
Sheet11
Old_Sheet11
Sheet4
Sheet6

And here the modified code:

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