Ответ 1
Вот какой-то код, есть какой-то установочный код, чтобы вы (или другие соавторы) могли запускать пример из двух книг, один из которых указывал на другой. Две книги будут сохранены в вашем каталоге Temp как часть настройки.
Для меня выход
Cell at Book2.xlsx!Sheet1!$A$2 has external workbook source of [Book1.xlsx]
Он работает, исследуя LinkSources для рабочей книги, а затем просматривает ячейки, которые ищут этот источник ссылок.
Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : Investigate
' DateTime : 06/02/2018 14:40
' Author : Simon
' Purpose : Start execution here. There is some setup code
'---------------------------------------------------------------------------------------
' Arguments :
' arg1 : arg1 description
'
Sub Investigate()
'**************************************************
' START of Experiment setup code
'**************************************************
Dim wb1 As Excel.Workbook, wb2 As Excel.Workbook
GetOrCreateMyTwoWorbooks "Book1", "SimonSub1", wb1, "Book2", "SimonSub2", wb2
wb1.Worksheets(1).Range("a1").Formula = "=2^4"
wb2.Worksheets(1).Range("a1").Formula = "=2^2"
wb2.Worksheets(1).Range("b1").Formula = "=3^2"
wb2.Worksheets(1).Range("a2").FormulaR1C1 = "=[" & wb1.Name & "]Sheet1!R1C1/r1c1*r1c2"
'**************************************************
' END of Experiment setup code
'**************************************************
'**************************************************
'* now the real logic begins
'**************************************************
Dim dicLinkSources As Scripting.Dictionary
Set dicLinkSources = LinkSources(wb2)
'* get all the cells containing formulae in the worksheet we're interested in
Dim rngFormulaCells As Excel.Range
Set rngFormulaCells = wb2.Worksheets(1).UsedRange.SpecialCells(xlCellTypeFormulas)
'* set up results container (one could report as we find them but I like to collate)
Dim dicExternalWorksheetPrecedents As Scripting.Dictionary
Set dicExternalWorksheetPrecedents = New Scripting.Dictionary
'* loop throught the subset of cells on the worksheet that have formulae
Dim rngFormulaCellsLoop As Excel.Range
For Each rngFormulaCellsLoop In rngFormulaCells
Dim sFormula As String
sFormula = rngFormulaCellsLoop.Formula '* I like a copy in my locals window
'* search for all the link sources (experiment has only one, chance are you'll have many)
Dim vSearchLoop As Variant
For Each vSearchLoop In dicLinkSources.Items
If VBA.InStr(1, sFormula, vSearchLoop, vbTextCompare) > 0 Then
'* we found one, add to collated results
dicExternalWorksheetPrecedents.Add wb2.Name & "!" & wb2.Worksheets(1).Name & "!" & rngFormulaCellsLoop.Address, vSearchLoop
End If
Next vSearchLoop
Next
'*print collated results
Dim lResultLoop As Long
For lResultLoop = 0 To dicExternalWorksheetPrecedents.Count - 1
Debug.Print "Cell at " & dicExternalWorksheetPrecedents.Keys()(lResultLoop) & " has external workbook source of " & dicExternalWorksheetPrecedents.Items()(lResultLoop)
Next lResultLoop
Stop
End Sub
'---------------------------------------------------------------------------------------
' Procedure : LinkSources
' DateTime : 06/02/2018 14:38
' Author : Simon
' Purpose : To acquire list of link sources and more importantly the search term
' we're going to see to look for external workbooks
'---------------------------------------------------------------------------------------
' Arguments :
' [in] wb : The workbook we want report on
' [out,retval] : returns a dictionary with the lik sources in the keys and search term in item
'
Function LinkSources(ByVal wb As Excel.Workbook) As Scripting.Dictionary
Static fso As Object
If fso Is Nothing Then Set fso = VBA.CreateObject("Scripting.FileSystemObject")
Dim dicLinkSources As Scripting.Dictionary
Set dicLinkSources = New Scripting.Dictionary
Dim vLinks As Variant
vLinks = wb.LinkSources(XlLink.xlExcelLinks)
If Not IsEmpty(vLinks) Then
Dim lIndex As Long
For lIndex = LBound(vLinks) To UBound(vLinks)
Dim sSearchTerm As String
sSearchTerm = ""
If fso.FileExists(vLinks(lIndex)) Then
Dim fil As Scripting.file
Set fil = fso.GetFile(vLinks(lIndex))
'* this is what we'll search for in the cell formulae
sSearchTerm = "[" & fil.Name & "]"
End If
dicLinkSources.Add vLinks(lIndex), sSearchTerm
Next lIndex
End If
Set LinkSources = dicLinkSources
End Function
'*****************************************************************************************************************
' __ __
'_____ ______ ___________ ____________ _/ |_ __ __ ______ ______ _____/ |_ __ ________
'\__ \ \____ \\____ \__ \\_ __ \__ \\ __\ | \/ ___/ / ___// __ \ __\ | \____ \
' / __ \| |_> > |_> > __ \| | \// __ \| | | | /\___ \ \___ \\ ___/| | | | / |_> >
'(____ / __/| __(____ /__| (____ /__| |____//____ > /____ >\___ >__| |____/| __/
' \/|__| |__| \/ \/ \/ \/ \/ |__|
'
'*****************************************************************************************************************
'* this is just something to setup the experiment, you won't need this hence the big banner :)
'*
Public Sub GetOrCreateMyTwoWorbooks(ByVal sWbName1 As String, ByVal sSubDirectory1 As String, ByRef pwb1 As Excel.Workbook, _
ByVal sWbName2 As String, ByVal sSubDirectory2 As String, ByRef pwb2 As Excel.Workbook)
Static fso As Object
If fso Is Nothing Then Set fso = VBA.CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set pwb1 = Application.Workbooks.Item(sWbName1)
Set pwb2 = Application.Workbooks.Item(sWbName2)
On Error GoTo 0
If pwb1 Is Nothing Then
Set pwb1 = Application.Workbooks.Add
Dim sSubDir1 As String
sSubDir1 = fso.BuildPath(Environ$("tmp"), sSubDirectory1)
If Not fso.FolderExists(sSubDir1) Then fso.CreateFolder (sSubDir1)
Dim sSavePath1 As String
sSavePath1 = fso.BuildPath(sSubDir1, sWbName1)
pwb1.SaveAs sSavePath1
End If
If pwb2 Is Nothing Then
Set pwb2 = Application.Workbooks.Add
Dim sSubDir2 As String
sSubDir2 = fso.BuildPath(Environ$("tmp"), sSubDirectory2)
If Not fso.FolderExists(sSubDir2) Then fso.CreateFolder (sSubDir2)
Dim sSavePath2 As String
sSavePath2 = fso.BuildPath(sSubDir2, sWbName2)
pwb2.SaveAs sSavePath2
End If
End Sub
