这是我能想到的一种方法，我将分两部分来解释。

第一部分

假设我们有一个命名范围Sid。
这个单词Sid可以以任何一种形式出现，如下图所示。为什么它以=开头？这在下面的Part2中已经解释过了。

=Sid    '<~~ 1
="Sid"  '<~~ 2
=XSid   '<~~ 3
=SidX   '<~~ 4
=_Sid   '<~~ 5
=Sid_   '<~~ 6
=(Sid)  '<~~ 7

任何其他的场景，我猜都是上述场景的子集，在我们的例子中，唯一有效的查找是第一个和最后一个，因为我们正在查找命名的范围。
所以这里有一个快速的函数来检查单元格公式是否有一个命名的范围。我相信它可以变得更有效

Function isNamedRangePresent(rng As Range, s As String) As Boolean
    Dim sFormula As String
    Dim pos1 As Long, pos2 As Long, sLen As Long, i As Long

    sFormula = rng.Formula: sLen = Len(sFormula)

    pos2 = 1

    Do
        pos1 = InStr(pos2, sFormula, s) - 1
        If pos1 < 1 Then Exit Do

        isNamedRangePresent = True

        For i = 65 To 90
            '~~> A-Z before Sid for example XSid
            If UCase(Mid(sFormula, pos1, 1)) = Chr(i) Then
                isNamedRangePresent = False
                Exit For
            End If
        Next i

        '~~> Check for " for example "Sid
        If isNamedRangePresent = True Then _
        If UCase(Mid(sFormula, pos1, 1)) = Chr(34) Then isNamedRangePresent = False
        '~~> Check for underscore for example _Sid
        If isNamedRangePresent = True Then _
        If UCase(Mid(sFormula, pos1, 1)) = Chr(95) Then isNamedRangePresent = False

        pos2 = pos1 + Len(s) + 1

        If pos2 <= sLen Then
            For i = 65 To 90
                '~~> A-Z after Sid for example SidX
                If UCase(Mid(sFormula, pos2, 1)) = Chr(i) Then
                    isNamedRangePresent = False
                    Exit For
                End If
            Next i

            '~~> "Sid
            If isNamedRangePresent = True Then _
            If UCase(Mid(sFormula, pos2, 1)) = Chr(34) Then isNamedRangePresent = False
            '~~> _Sid
            If isNamedRangePresent = True Then _
            If UCase(Mid(sFormula, pos2, 1)) = Chr(95) Then isNamedRangePresent = False
        End If
    Loop
End Function

在第一种和最后一种情况下，Debug.Print isNamedRangePresent(Range("D2"), "Sid")会给予True，请看这个

第二部分

现在来看看.Find。我发现你在工作表中只搜索了一次。因为你可以有很多Sid的场景，所以你不能只有一个.Find。你必须使用.FindNext。关于如何使用它，请参见THIS链接。我已经在那里解释过了，所以我不会在这里解释。

**我们可以通过只搜索那些包含公式的单元格来提高.Find的效率。**为此，我们必须使用.SpecialCells(xlCellTypeFormulas)。这解释了为什么我们在PART1的示例中使用“=”。：）

下面是一个示例（底部添加了PART1代码）

Sub Sample()
    Dim oRange As Range, aCell As Range, bCell As Range
    Dim oSht As Worksheet
    Dim strSearch As String, FoundAt As String

    Set oSht = Worksheets("Sheet1")

    '~~> Set your range where you need to find - Only Formula Cells
    On Error Resume Next
    Set oRange = oSht.Cells.SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0

    If Not oRange Is Nothing Then
        strSearch = "Sid"

        Set aCell = oRange.Find(What:=strSearch, LookIn:=xlFormulas, _
                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            Set bCell = aCell

            '~~> Check if the cell has named range
            If isNamedRangePresent(aCell, strSearch) Then FoundAt = aCell.Address

            Do
                Set aCell = oRange.FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bCell.Address Then Exit Do

                    '~~> Check if the cell has named range
                    If isNamedRangePresent(aCell, strSearch) Then FoundAt = FoundAt & ", " & aCell.Address
                Else
                    Exit Do
                End If
            Loop
        Else
            MsgBox SearchString & " not Found"
            Exit Sub
        End If

        If FoundAt = "" Then
            MsgBox "The Named Range was not found"
        Else
            MsgBox "The Named Range has been found these locations: " & FoundAt
        End If
    End If
End Sub

Function isNamedRangePresent(rng As Range, s As String) As Boolean
    Dim sFormula As String
    Dim pos1 As Long, pos2 As Long, sLen As Long, i As Long

    sFormula = rng.Formula: sLen = Len(sFormula)

    pos2 = 1

    Do
        pos1 = InStr(pos2, sFormula, s) - 1
        If pos1 < 1 Then Exit Do

        isNamedRangePresent = True

        For i = 65 To 90
            '~~> A-Z before Sid for example XSid
            If UCase(Mid(sFormula, pos1, 1)) = Chr(i) Then
                isNamedRangePresent = False
                Exit For
            End If
        Next i

        '~~> Check for " for example "Sid
        If isNamedRangePresent = True Then _
        If UCase(Mid(sFormula, pos1, 1)) = Chr(34) Then isNamedRangePresent = False
        '~~> Check for underscore for example _Sid
        If isNamedRangePresent = True Then _
        If UCase(Mid(sFormula, pos1, 1)) = Chr(95) Then isNamedRangePresent = False

        pos2 = pos1 + Len(s) + 1

        If pos2 <= sLen Then
            For i = 65 To 90
                '~~> A-Z after Sid for example SidX
                If UCase(Mid(sFormula, pos2, 1)) = Chr(i) Then
                    isNamedRangePresent = False
                    Exit For
                End If
            Next i

            '~~> "Sid
            If isNamedRangePresent = True Then _
            If UCase(Mid(sFormula, pos2, 1)) = Chr(34) Then isNamedRangePresent = False
            '~~> _Sid
            If isNamedRangePresent = True Then _
            If UCase(Mid(sFormula, pos2, 1)) = Chr(95) Then isNamedRangePresent = False
        End If
    Loop
End Function

产出

呸！

此代码使用这些名称创建工作簿的副本。然后，它将遍历并删除复制的工作簿中的名称列表中的每个名称。它将计算前后工作簿中的公式错误数。如果错误数相同，则不使用该名称。如果错误数不同，则使用该名称。
我喜欢在这种非常复杂的情况下做这种测试。这意味着你不必担心测试的复杂规则。你可以根据结果来回答问题。
由于测试都是在副本上完成的，所以应该是安全的。不过一定要在之前保存所有的工作！
要使用，请将您的名称列表放入工作簿中，并将该列表的范围命名为“NamesToTest”：

然后将以下代码放入同一工作簿中并运行：

Sub CheckNameUsage()
Dim WorkbookWithList As Excel.Workbook
Dim WorkbookWithNames As Excel.Workbook
Dim TempWb As Excel.Workbook
Dim cell As Excel.Range
Dim NameToCheck As String
Dim ws As Excel.Worksheet
Dim ErrorRange As Excel.Range
Dim ErrorsBefore As Long
Dim ErrorsAfter As Long
Dim NameUsed As Boolean

Set WorkbookWithList = ThisWorkbook
Set WorkbookWithNames = Workbooks("SO - wb to test.xlsx")    'adjust to suit
WorkbookWithNames.Worksheets.Copy    'Workbooks.Add(WorkbookWithNames.FullName)
Set TempWb = ActiveWorkbook

For Each cell In WorkbookWithList.Names("NamesToTest").RefersToRange.Cells
    NameToCheck = cell.Value
    ErrorsBefore = 0
    For Each ws In TempWb.Worksheets
        Set ErrorRange = Nothing
        On Error Resume Next
        Set ErrorRange = ws.Cells.SpecialCells(xlCellTypeFormulas, 16)
        On Error GoTo 0
        If Not ErrorRange Is Nothing Then
            ErrorsBefore = ErrorsBefore + ErrorRange.Cells.Count
        End If
    Next ws
    TempWb.Names(NameToCheck).Delete
    ErrorsAfter = 0
    For Each ws In TempWb.Worksheets
        Set ErrorRange = Nothing
        On Error Resume Next
        Set ErrorRange = ws.Cells.SpecialCells(xlCellTypeFormulas, 16)
        On Error GoTo 0
        If Not ErrorRange Is Nothing Then
            ErrorsAfter = ErrorsAfter + ErrorRange.Cells.Count
        End If
    Next ws
    NameUsed = True
    If ErrorsBefore = ErrorsAfter Then
        NameUsed = False
    End If
    Debug.Print NameToCheck; " - Errors Before = " & ErrorsBefore; ", Errors After = " & ErrorsAfter; ", Used = " & NameUsed; ""
Next cell
TempWb.Close False
End Sub

结果将显示在调试窗口中：

这段代码很有希望是非常容易理解的。SpecialCells是值得了解的，所以如果有必要的话，请仔细阅读它。在本例中，它标识了有错误的单元格--这就是16参数。
请注意，这只检查工作簿级别的名称。如有必要，您可以添加工作表级别的检查。

下面的代码对我来说是有效的。
1)可以使用range.ShowDependents方法绘制指向从属于该区域的单元格的箭头。完成后，使用range.ShowDependents True删除箭头。
2)一旦箭头被画出来，range.NavigateArrow就可以跟随这些箭头，并返回结果范围。我找不到任何文档说明如果没有依赖范围会发生什么。通过实验，我能够确定，如果没有依赖范围，它将返回原始范围。

Sub test_for_dependents(nm As Name)
    Dim nm_rng As Range, result As Range
    Dim i As Long

    Set nm_rng = nm.RefersToRange
    nm_rng.ShowDependents
    Set result = nm_rng.NavigateArrow(False, 1, 1)
    If result.Parent.Name = nm_rng.Parent.Name And result.Row = nm_rng.Row _
        And result.Column = nm_rng.Column Then
        MsgBox "Named range """ & nm.Name & """ isn't used!"
    End If
    nm_rng.ShowDependents True

    Set nm_rng = Nothing
    Set result = Nothing
End Sub

Sub test_all_names()
    Dim nm As Name
    Dim sht As Worksheet

    For Each nm In ThisWorkbook.Names
        test_for_dependents nm
    Next nm

    For Each sht In ThisWorkbook.Sheets
        For Each nm In sht.Names
            test_for_dependents nm
        Next nm
    Next sht

    Set nm = Nothing
    Set sht = Nothing
End Sub

下面的NamesInCells宏报告引用活动工作簿中每个已定义名称（命名区域）的公式单元格数。结果位于工作簿的NamesInCells工作表中从第1行开始的A：D列（Scope、Name、RefersTo、Cells）中。如果该工作表不存在，则将其添加到最后一张工作表之后。
对于每个可见的名称（未隐藏），宏将使用私有函数Formula_Errors来确定在名称的RefersTo属性无效之前和之后有多少公式单元格出错。前后的差值是公式中引用该名称的单元格数。但是，如果在之前生成错误的单元格公式中使用了名称，该单元格的after结果将相同。此问题由私有函数Prior_Errors解决，该函数确定在Name无效之前Name是否出现在错误单元格的公式中。Prior_Errors使用的InStr方法不完美，但仅适用于在启动宏之前有错误的公式（希望很少）。此外，如果在具有初始错误的单独公式中，则具有工作簿范围的名称和具有工作表范围的重复名称可能会被额外计数。
这个宏的灵感来自Doug Glancy上面的回答：https://stackoverflow.com/a/26691025/10172433

Public Sub NamesInCells()
    Const myName As String = "NamesInCells"
    Dim WB As Workbook, oName As Name, A() As Variant, vCells As Variant
    Dim sScope As String, sName As String, sRefersTo As String
    Dim nRows As Long, nR As Long, nBase As Long, n As Integer
    Set WB = ActiveWorkbook
    nRows = WB.Names.Count
    If nRows = 0 Then
        MsgBox "There are no defined names in the active workbook", _
            vbInformation, myName
        Exit Sub
    End If
    nRows = nRows + 1
    ReDim A(1 To 4, 1 To nRows)
    nR = 1
    A(1, 1) = "Scope"
    A(2, 1) = "Name"
    A(3, 1) = "RefersTo"
    A(4, 1) = "Cells"
    nBase = Formula_Errors(WB)
    For Each oName In WB.Names
        With oName
            If .Visible Then 'skip hidden names
                n = InStrRev(.Name, "!")
                If n = 0 Then
                    sScope = "Workbook"
                    sName = .Name
                ElseIf n > 1 Then
                    sScope = Left(.Name, (n - 1))
                    sName = Mid(.Name, (n + 1))
                End If
                sRefersTo = .RefersTo
                If Left(sScope, 1) = "'" Then _
                    sScope = Mid(sScope, 2, (Len(sScope) - 2))
                .RefersTo = "#REF!"
                vCells = Formula_Errors(WB) - nBase
                .RefersTo = sRefersTo
                vCells = vCells + Prior_Errors(WB, .Name)
                nR = nR + 1
                A(1, nR) = sScope
                A(2, nR) = sName
                A(3, nR) = "'" & sRefersTo
                A(4, nR) = vCells
            End If
        End With
    Next oName
    If nR < 2 Then
        MsgBox "There are no visible defined names in the active workbook", _
            vbInformation, myName
        Exit Sub
    ElseIf nR < nRows Then
        ReDim Preserve A(1 To 4, 1 To nR)
    End If
    On Error Resume Next
        With WB
            .Worksheets(myName).Activate
            If Err = 0 Then
                Range("A:D").Clear
            Else
                .Worksheets.Add After:=.Sheets(.Sheets.Count)
                ActiveSheet.Name = myName
            End If
        End With
    On Error GoTo 0
    Range("A1").Select
    Selection.Resize(nR, 4).Value = Application.Transpose(A)
End Sub

Private Function Formula_Errors(WB As Workbook) As Long
    Dim WS As Worksheet, R As Range, nCount As Long
    For Each WS In WB.Worksheets
        On Error Resume Next
            Set R = WS.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
            If Err = 0 Then nCount = nCount + R.Count
        On Error GoTo 0
    Next WS
    Formula_Errors = nCount
End Function

Private Function Prior_Errors(WB As Workbook, Name As String) As Long
    Dim WS As Worksheet, R As Range, rCell As Range, nCount As Long
    Dim sWS As String, sN As String, sF As String, n As Integer
    n = InStrRev(Name, "!")
    If n > 1 Then
        sN = Mid(Name, (n + 1))
        sWS = Left(Name, (n - 1))
        If Left(sWS, 1) = "'" Then sWS = Mid(sWS, 2, (Len(sWS) - 2))
    End If
    For Each WS In WB.Worksheets
        On Error Resume Next
            Set R = WS.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
            If Err = 0 Then
                For Each rCell In R
                    sF = rCell.Formula
                    If WS.Name = sWS Then
                        If InStr(1, sF, sN, vbBinaryCompare) > 0 Then
                            nCount = nCount + 1
                        End If
                    ElseIf InStr(1, sF, Name, vbBinaryCompare) > 0 Then
                        nCount = nCount + 1
                    End If
                Next rCell
            End If
        On Error GoTo 0
    Next WS
    Prior_Errors = nCount
End Function