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

Question

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

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

任何接近这个的替代解决方案也是受欢迎的.我本身并不是在寻找一个完整的解决方案,但我能指出正确的方向.

Answer 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