是否有办法在Excel中使用VBA和/或某些公式来检查是否有其他工作簿/工作表引用单元格?理想情况下,也可以从哪些工作簿/工作表,但如果这不可能,那也没关系。
假设我有一个包含代理地址列表的工作簿,我想通过检查是否有任何其他工作簿引用其单元格来了解代理是否已被使用。这是为了指示它是免费代理还是已经在使用。
也欢迎任何与此接近的替代解决方案。我本身并不是在寻找一个完整的解决方案,但是我可以通过指向正确的方向来实现目标。
答案 0 :(得分:6)
这是一些代码,有一些设置代码,以便您(或其他协作者)可以通过两个工作簿的示例运行,一个指向另一个。作为设置的一部分,两个工作簿将保存到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
答案 1 :(得分:2)