PDA

View Full Version : Show Sheets which have links to other sheets



Cinema
07-01-2019, 01:54 PM
Hi

the code below should loop through the worksheets and list all links to other sheets. There should be a table as an output where we can see the sheet which has links and the according links for example



Sheet1

Sheet2
Sheet4



Sheet2

Sheet1





But I cannot implement the output part !






Sub ShowLinks()

Dim Rng, c As Range
Dim dic, dic2 As Object
Dim x, y, z
Dim j, k, m As Long
Dim sht As Worksheet
Dim strSheets As String
Dim wb, wb_t As Workbook
Dim ws, ws_op As Worksheet

Dim folderName As String
Dim filename As String
Dim path As String

Set wb = ThisWorkbook
Set ws = ThisWorkbook.Worksheets("Input")
Set ws_op = ThisWorkbook.Worksheets("Output")


Set dic = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")


'Determine folder name and file name
folderName = ws.Range("B1").Value
filename = ws.Range("B2").Value
'Check if path has the right form
If Right(folderName, 1) <> "\" Then folderName = folderName & "\"
path = folderName & filename

'Check if Workbook is already open
If IsWorkbookOpen(path) Then
MsgBox "File already in use!"

Else
'Open the file in Microsoft Excel
Set wb_t = Application.Workbooks.Open(path)

End If


With wb_t
Dim xSheet As Worksheet


For Each xSheet In Worksheets



' Search for formulas and GoTo Error Handler if no formulas are found
On Error GoTo SortBySize
Set Rng = xSheet.Cells.SpecialCells(xlCellTypeFormulas)
SortBySize:
On Error GoTo 0



j = 0
'Search for references to another sheets
For Each c In Rng
If InStr(1, c.Formula, "!") > 0 Then
x = Split(c.Formula, "!")
If Not dic.exists(x(0)) Then
j = j + 1
dic.Add x(0), j
End If
End If
Next c

If j = 0 Then GoTo Line1 'no formulas with links found



y = dic.keys


'Now we have a list of unique strings containing sheet names
'referenced from this sheet. Next step is to list just the sheet names.
m = 0
For k = LBound(y) To UBound(y)
For Each sht In ActiveWorkbook.Worksheets
If InStr(1, y(k), sht.name) > 1 Then
If Not dic2.exists(sht.name) Then
m = m + 1

dic2.Add sht.name, m

End If
Exit For
End If
Next sht

Next k
Dim LastRow As Integer
strSheets = Join(dic2.keys, vbCrLf)
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
ws_op.Range("A2") = xSheet.name
ws_op.Range("A2").Offset(0, 1) = strSheets




Line1:

Next xSheet ' Loop through Worksheets and search links between sheets

End With
wb_t.Close





ExitHere:
Set dic2 = Nothing
Set dic = Nothing
Set Rng = Nothing

End Sub
Function IsWorkbookOpen(filename As String) As Boolean
Dim filenum As Long, ErrNo As Long
On Error Resume Next 'Turn error checking off
filenum = FreeFile() 'Get a free file number
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkbookOpen = False
Case 70: IsWorkbookOpen = True
Case Else: Error ErrNo
End Select
End Function