Sub Связи_активной_книги()
If MsgBox("Вывести список всех связей книги на новый лист?", vbYesNo + vbQuestion, "Связи книги") = vbNo Then Exit Sub
Dim wsSh As Worksheet
On Error Resume Next
Set wsSh = Sheets("Связи_книги")
If wsSh Is Nothing Then Sheets.Add(Sheets(1)).name = "Связи_книги"
wsSh.Activate
Cells.Clear
Sheets("Связи_книги").Move before:=Sheets(1)
Dim spisws(), spiscell(), spl(), spce(), splni(), i, j, ii, iii, nl, iLinks As Variant
Dim ws As Worksheet, rr As Range, cell As Range, rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim rlastf, fff, nml, bNewArrow As Boolean
Application.ScreenUpdating = False
iLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(iLinks) Then nl = UBound(iLinks)
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("Связи_книги").Activate
On Error Resume Next
Range(Cells(1, 2), Cells(i + 1, 2)) = Application.WorksheetFunction.Transpose(spce)
Range(Cells(1, 3), Cells(i + 1, 3)) = Application.WorksheetFunction.Transpose(splni)
Sheets("Связи_книги").Activate
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("Связи_книги").Hyperlinks.Add anchor:=Cells(j + 1, 3), Address:=Cells(j + 1, 3).Value
Else
Cells(j + 1, 3) = "Битая ссылка"
End If
End If
Worksheets("Связи_книги").Hyperlinks.Add anchor:=Cells(j + 1, 1), Address:="", SubAddress:="'" & spl(j) & "'" & "!" & spce(j)
Cells(j + 1, 1).Formula = spl(j)
Worksheets("Связи_книги").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
End Sub |
