Sub List_Worksheet_Links()
Dim wsList As Worksheet, ws As Worksheet
Dim i As Long, j As Long, nr As Long
Dim frmlacells As Range, c As Range
Dim RX As Object, ary As Object
Dim s As String, t As String, fsname As String, Pat As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Link List").Delete
On Error GoTo 0
Application.DisplayAlerts = True
For Each ws In ThisWorkbook.Worksheets
Pat = Pat & "'*|'*" & ws.Name
Next ws
Pat = "(" & Replace(Pat, "'*|", "", 1, 1, 1) & "'*)(?=\!)"
Set RX = CreateObject("VBscript.Regexp")
With RX
.Global = True
.Pattern = Pat
End With
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Link List"
Set wsList = ActiveSheet
wsList.Range("A1:E1").Value = Array("Formula Sheet", "Cell", "Sheet(s) Linked To", "Formula", "Formula Result")
wsList.Columns("A:D").NumberFormat = "@"
nr = 1
For i = 1 To Sheets.Count - 1
fsname = Sheets(i).Name
Set frmlacells = Nothing
On Error Resume Next
Set frmlacells = Sheets(i).UsedRange.SpecialCells(xlFormulas)
On Error GoTo 0
If Not frmlacells Is Nothing Then
For Each c In frmlacells
s = Replace(c.Formula, "=", "", 1, 1, 1)
If RX.Test(s) Then
t = ""
Set ary = RX.Execute(s)
For j = 0 To ary.Count - 1
t = t & ", " & ary(j)
Next j
nr = nr + 1
t = Replace(Replace(t, ", ", "", 1, 1, 1), "'", "", 1, -1, 1)
With wsList.Cells(nr, 1)
.Value = fsname
.Offset(, 1).Value = c.Address(0, 0)
.Offset(, 2).Value = t
.Offset(, 3).Value = "=" & s
.Offset(, 4).Value = c.Value
End With
End If
Next c
End If
Next i
wsList.Columns("A:E").AutoFit
Application.ScreenUpdating = True
End Sub