Sub Svyazi()
' выводит на новый лист все связи между листами книги
Dim spisws()
Dim spiscell()
Dim spl()
Dim spce()
Dim splni()
Dim i, j, ii, iii, nl
Dim iLinks As Variant
Dim ws As Worksheet
Dim rr As Range
Dim cell As Range
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim rlastf
Dim fff
Dim nml
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
'внешние связи
iLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(iLinks) Then
nl = UBound(iLinks)
End If
For Each ws In Sheets
ws.Select
On Error Resume Next
Set rr = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
If Err.Number = 0 Then
On Error GoTo 0
'поиск внешних связей
For Each cell In rr
If Not IsEmpty(nl) Then
If InStr(cell.Formula, "[") > 0 Then
rlastf = Replace(cell.Formula, "[", "")
For iii = 1 To nl
If InStr(rlastf, iLinks(iii)) > 0 Then
i = i + 1
ReDim Preserve splni(0 To i)
ReDim Preserve spl(0 To i)
ReDim Preserve spce(0 To i)
ReDim Preserve spisws(0 To i)
ReDim Preserve spiscell(0 To i)
spl(i) = ws.Name
spce(i) = cell.Address(False, False, xlA1)
splni(i) = iLinks(iii)
End If
Next iii
End If
End If
'поиск ссылок на другие листы книги
cell.Select
ActiveCell.ShowPrecedents
Set rLast = ActiveCell
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=True, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
If rLast.Worksheet.Parent.Name = ActiveCell.Worksheet.Parent.Name Then
If rLast.Worksheet.Name <> ActiveCell.Parent.Name Then '
i = i + 1
ReDim Preserve splni(0 To i)
ReDim Preserve spl(0 To i)
ReDim Preserve spce(0 To i)
ReDim Preserve spisws(0 To i)
ReDim Preserve spiscell(0 To i)
spl(i) = ws.Name
spce(i) = rLast.Address(False, False, xlA1)
spisws(i) = Selection.Parent.Name
spiscell(i) = Selection.Address(False, False, xlA1)
End If
End If
iLinkNum = iLinkNum + 1 ' перебор аргументов
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
Next cell
Set rr = Nothing
End If
Next ws
'вывод данных
Sheets.Add
nml = Application.InputBox("Введите имя листа для вывода")
ActiveSheet.Name = nml
Sheets(nml).Move Before:=Sheets(1)
Range(Cells(1, 2), Cells(i + 1, 2)) = Application.WorksheetFunction.Transpose(spce)
Range(Cells(1, 3), Cells(i + 1, 3)) = Application.WorksheetFunction.Transpose(splni)
Range(Cells(1, 5), Cells(i + 1, 5)) = Application.WorksheetFunction.Transpose(spiscell)
Range(Cells(1, 1), Cells(1, 6)) = Array("лист", "ячейка", "внешняя ссылка", "лист ссылки", "ячейки ссылки", "примечание")
Range("A1:F1").AutoFilter
Range("B2").Select
ActiveWindow.FreezePanes = True
'для внешних связей проверка существования файла и создание гиперссылки на него, _
создание гиперссылок на листы
For j = 1 To i
If Not IsEmpty(Cells(j + 1, 3)) Then
Set fff = CreateObject("Scripting.FileSystemObject")
If fff.FileExists(Cells(j + 1, 3).Value) Then
Set fff = Nothing
Worksheets(nml).Hyperlinks.Add Anchor:=Cells(j + 1, 3), Address:=Cells(j + 1, 3).Value
Else
Cells(j + 1, 3) = "Битая ссылка"
End If
End If
Worksheets(nml).Hyperlinks.Add Anchor:=Cells(j + 1, 1), Address:="", SubAddress:="'" & spl(j) & "'" & "!" & spce(j)
Cells(j + 1, 1).Formula = spl(j)
Worksheets(nml).Hyperlinks.Add Anchor:=Cells(j + 1, 4), Address:="", SubAddress:="'" & spisws(j) & "'" & "!A1"
Cells(j + 1, 4).Formula = spisws(j)
Next j
Cells.Columns.AutoFit
With Cells
.VerticalAlignment = xlTop
.WrapText = True
End With
Application.ScreenUpdating = True
End Sub
