检测其他工作簿中对单元格的引用？

Question

有没有办法使用 VBA 和/或 Excel 中的某些公式来检查是否有其他工作簿/工作表引用了一个单元格？理想情况下，也来自哪些工作簿/工作表，但如果这是不可能的，那也没关系。

假设我有一个包含代理地址列表的工作簿，我想通过检查是否有任何其他工作簿引用其单元格来了解代理是否已被使用。这是为了指示它是免费代理还是已在使用中。

也欢迎任何接近此的替代解决方案。我本身并不是在寻找一个完整的解决方案，但是通过将我指向正确的方向，我可以走得更远。

Answer 1

这里有一些代码，有一些设置代码，以便您（或其他合作者）可以通过两个工作簿的示例运行，一个指向另一个。作为设置的一部分，两个工作簿会保存到您的 Temp 目录中。

对我来说输出是

 Cell at Book2.xlsx!Sheet1!$A$2 has external workbook source of [Book1.xlsx]

它的工作原理是检查工作簿的链接源，然后扫描单元格以查找该链接源。

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

Answer 2

在功能区 > 公式 > 跟踪先例 > 单击：

它会告诉你以下先例单元格：

• 当前工作表中的单元格
• 来自不同工作表的单元格
• 打开的工作簿中的单元格

如果您想查看超过 1 个单元格的百分比，请考虑以下事项：

Sub TestMe()
    Dim myCell  As Range
    For Each myCell In ActiveSheet.UsedRange
        If myCell.HasFormula Then myCell.ShowPrecedents
    Next myCell
End Sub

然后你可以得到这样的东西：