VBA to automatically audit a workbook to identify the references in a sheet

[Johnny C]

Hi

OK so this isn't a question, but I couldn't find anywhere else to post it. if a mod spots this and knows a better place for it to go, please move it for me, thanks.

I need as part of our Infernal Audit requirements, to document which sheets/external references are made for every sheet in a large-ish (75sheet) workbook, which is modelling a forecast and has lots of analysis referencing other sheets.

it would take me forever to do it by hand so I figured I could better spend less time creating some VBA to do it than doing it by hand, and this is the outcome.

It's not perfect, I'm not too worried about external references or web links with odd characters, and it doesn't cope with tabnames with unprintable characters (which you can have in a worksheet name - go figure!) nor will it deal with INDIRECTed tabs. I'm sure it could be modified to do all that though I'm not going to

Someone may find it useful. Just copy & paste into your personal.xlsb or wherever and add a button to a ribbon or the QAT and you're good to go.

Cheers

Option Explicit
Sub WorkbookReferences()

' ========================================================================================================================
' This goes through all the sheets in a workbook, goes through all the cells and identifies which sheets are referenced.
' These are then noted on a WorksheetReferences tab.
' ========================================================================================================================


' =============== Declarations ===============
' Boolean
Dim boolRefFound As Boolean
' String
Dim strCellFormula$, strMatchRange$, strReftext$, strColLetter$, strShtName$
' integer
Dim intVisStatus%
' Long
Dim lngNextRefCol&, lngLastRow&, lngLastCol&, lngRowCount&, lngColCount&, lngLastRefRow&
Dim lngBracketPos&, lngApostrophePos&, lngNextRow&, lngRowOffset&
' Variant
Dim varCol
Dim varTint
Dim sht

' ================= If no WorkbookReferences sheet exists create one ==================
On Error Resume Next
Sheets("WorkbookReferences").Select
If Err.Number <> 0 Then
    On Error GoTo 0
    Sheets.Add
    ActiveSheet.Name = "WorkbookReferences"
    Sheets("Workbookreferences").Cells(4, 1).Value = "Sheet name"
    Sheets("Workbookreferences").Cells(5, 1).Value = "Sheet visible"
End If
On Error GoTo 0

' ================= Clear existing data ==================
lngNextRefCol = Sheets("WorkbookReferences").Cells.SpecialCells(xlLastCell).Column
strColLetter = Split(Cells(1, lngNextRefCol).Address, "$")(1)
Sheets("WorkbookReferences").Range("B:" & strColLetter).Clear


' ================= Loop through sheets and create column for each sheet ==================
lngNextRefCol = 2
strColLetter = "B"
For Each sht In Sheets
    strShtName = sht.Name
    lngNextRefCol = lngNextRefCol + 1
    strColLetter = Split(Cells(1, lngNextRefCol).Address, "$")(1)
    lngRowOffset = 4
    varCol = sht.Tab.Color
    If varCol <> False Then Sheets("Workbookreferences").Cells(lngRowOffset, lngNextRefCol).Interior.Color = varCol
    varTint = sht.Tab.TintAndShade
    If varTint <> False Then Sheets("Workbookreferences").Cells(lngRowOffset, lngNextRefCol).Interior.TintAndShade = varTint
    Sheets("Workbookreferences").Cells(lngRowOffset, lngNextRefCol).Value = strShtName
    intVisStatus = sht.Visible
    lngRowOffset = 5
    Select Case intVisStatus
    Case 0
        Sheets("Workbookreferences").Cells(lngRowOffset, lngNextRefCol).Value = "Hidden"
    Case -1
        Sheets("Workbookreferences").Cells(lngRowOffset, lngNextRefCol).Value = "Shown"
    Case 2
        Sheets("Workbookreferences").Cells(lngRowOffset, lngNextRefCol).Value = "Very hidden"
    End Select
    
' ================= Refresh ==================
    DoEvents
    
' ================= Loop through cells on sheet and identify formula cells ==================
    lngLastRow = sht.Cells.SpecialCells(xlLastCell).Row
    lngLastCol = sht.Cells.SpecialCells(xlLastCell).Column
    For lngRowCount = 1 To lngLastRow
        For lngColCount = 1 To lngLastCol
            strCellFormula = sht.Cells(lngRowCount, lngColCount).Formula
            If Left(strCellFormula, 1) = "=" Then
                boolRefFound = True
' ================= Identify sheets in formula, strip first function off ==================
' ================= This is recursive, once it finds a reference it uses that and =========
' ================= then runs on what's left until there are no references left ===========
                Do While boolRefFound <> False
                    If InStr(1, strCellFormula, "!") = 0 Then boolRefFound = False
                    If boolRefFound = True Then
                        lngLastRefRow = Sheets("Workbookreferences").Cells.SpecialCells(xlLastCell).Row
                        strMatchRange = "$" & strColLetter & "$1:$" & strColLetter & "$" & lngLastRefRow
                        If Left(strCellFormula, 1) = "=" Then strCellFormula = Right(strCellFormula, Len(strCellFormula) - 1)
                        lngBracketPos = InStr(1, strCellFormula, "(")
                        lngApostrophePos = InStr(1, strCellFormula, "'")
                        If lngBracketPos > 0 Then
                            If lngApostrophePos > 0 Then
                                If lngBracketPos < lngApostrophePos Then
                                    strCellFormula = Mid(strCellFormula, lngBracketPos + 1, Len(strCellFormula) - lngBracketPos - 1)
                                Else
                                    strCellFormula = Mid(strCellFormula, lngApostrophePos + 1, Len(strCellFormula) - lngApostrophePos - 1)
                                End If
                            Else
                                strCellFormula = Mid(strCellFormula, lngBracketPos + 1, Len(strCellFormula) - lngBracketPos - 1)
                            End If
                        End If
' ================= If this is a formula, check if it's already been found, if not then add it to the references sheet ======
                        If InStr(1, strCellFormula, "!") > 0 Then
                            strReftext = " " & GetSheetName2(Mid(strCellFormula, 1, InStr(1, strCellFormula, "!") - 1))
                            If Mid(strReftext, 2, 1) = "'" Then strReftext = " " & Right(strReftext, Len(strReftext) - 2)
                            If IsError(Application.Match(strReftext, Sheets("Workbookreferences").Range(strMatchRange), 0)) Then
                                lngLastRefRow = Sheets("Workbookreferences").Cells.SpecialCells(xlLastCell).Row
                                lngNextRow = Sheets("WorkbookReferences").Cells(lngLastRefRow + 10, strColLetter).End(xlUp).Row + 1
                                Sheets("WorkbookReferences").Cells(lngNextRow, lngNextRefCol).Value = strReftext
                            End If
                            strCellFormula = GetSheetName(strCellFormula)
                        End If
                    End If
                Loop
            End If
        Next lngColCount
    Next lngRowCount
Next sht
End Sub

Private Function GetSheetName(ByVal strInputString$) As String

Dim intQuotecount%
Dim lngStart&, lngCounter&
Dim strStub$, strTabname$, strChar$, strQuoteChars$

GetSheetName = ""
strQuoteChars = "!""#$%&'()*+,-/1:;<=>?@[\]^`{|}~‚„‹•›¢£¥¦©«¬®»"
lngStart = InStr(1, strInputString, "!")
If lngStart = 0 Then Exit Function
strStub = Right(strInputString, Len(strInputString) - lngStart)
strTabname = ""
intQuotecount = 0
For lngCounter = lngStart - 1 To 1 Step -1
    strChar = Mid(strInputString, lngCounter, 1)
    If lngCounter = lngStart - 1 And strChar = "'" Then
        intQuotecount = 1
    Else
        If strChar = "'" And intQuotecount = 1 Then
            GetSheetName = strChar & strTabname & strStub
            Exit Function
        End If
        If InStr(1, strQuoteChars, strChar) > 0 And intQuotecount = 0 Then
            GetSheetName = strTabname & strStub
            Exit Function
        End If
        strTabname = strChar & strTabname
    End If
Next lngCounter
GetSheetName = strTabname & strStub
End Function
Private Function GetSheetName2(ByVal strInputString$) As String

Dim intQuotecount%
Dim lngStart&, lngCounter&
Dim strStub$, strTabname$, strChar$, strQuoteChars$

GetSheetName2 = ""
strQuoteChars = "!""#$%&'()*+,-/1:;<=>?@[\]^`{|}~‚„‹•›¢£¥¦©«¬®»"
lngStart = Len(strInputString)
If lngStart = 0 Then Exit Function
strTabname = ""
intQuotecount = 0
For lngCounter = lngStart To 1 Step -1
    strChar = Mid(strInputString, lngCounter, 1)
    If lngCounter = lngStart And strChar = "'" Then
        intQuotecount = 1
    Else
        If strChar = "'" And intQuotecount = 1 Then
            GetSheetName2 = strChar & strTabname
            Exit Function
        End If
        If InStr(1, strQuoteChars, strChar) > 0 And intQuotecount = 0 Then
            GetSheetName2 = strTabname
            Exit Function
        End If
        strTabname = strChar & strTabname
    End If
Next lngCounter
GetSheetName2 = strTabname
End Function