在大型工作簿中查找正在使用哪个命名范围

Question

我有近20张工作簿的工作簿中的594个命名范围列表，每个工作表有大约200列数据。我需要找出正在使用的命名范围的位置，以删除不相关的范围。我将一个命名区域列表粘贴到表单上，然后尝试通过记录它们来查找它们是否在公式中使用，然后在所有表单和列中使用find方法。问题是尽管使用了lookin xlformulas，但它会检索指定的范围，即使它只是一个文本。

这里是我的（更新）的尝试（如果不是明显了，我是一个业余的）：

Application.ScreenUpdating = False 

Count = ActiveWorkbook.Sheets.Count 

Sheets(Count).Activate 

Dim locr(1 To 595) 
Dim locc(1 To 595) 
Dim locn(1 To 595) 
Dim nam(1 To 595) 

Dim rng As Range 

Range("a1").Select 

    For X = 1 To 595 'populate array with named ranges 
     ActiveCell.Offset(1, 0).Select 
     nam(X) = ActiveCell.Value 
    Next X 


      For i = 1 To 595 'name loop 


       For j = 1 To (Count - 1) 'sheet loop 


        Sheets(j).Activate 
        On Error Resume Next 
        Set orange = Sheets(j).Cells.SpecialCells(xlCellTypeFormulas) 'limit range to cells that only contain formulas 

        On Error GoTo 20 'if no formulas in sheet, go to next sheet 

         If Not orange Is Nothing Then 
          Set rng = orange.Find(What:=nam(i), _ 
              LookIn:=xlFormulas, _ 
              LookAt:=xlPart, _ 
              SearchOrder:=xlByRows, _ 
              SearchDirection:=xlNext, _ 
              MatchCase:=False) 'find named range 

           If Not rng Is Nothing Then 'if named range found 

            Application.Goto rng, True 'go to cell where name range found and record address 

            locr(i) = ActiveCell.Row 
            locc(i) = ActiveCell.Column 
            locn(i) = ActiveSheet.Name 

           GoTo 10 'value found, go to next sheet 

           Else 

           End If 

         Else 
         End If 


20    Next j 

      locr(i) = "" 'record empty since "rng" is empty 
      locr(i) = "" 
      locr(i) = "" 

10   Next i 

Sheets(Count).Activate 
Range("c1").Select 
b = 1 

    For a = 1 To 595 'populate addresses of named ranges 


    ActiveCell.Offset(b, 2).Value = locr(a) 
    ActiveCell.Offset(b, 1).Value = locc(a) 
    ActiveCell.Offset(b, 0).Value = locn(a) 
    b = b + 1 

    Next a 

Answer 1

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

PART 1

比方说，我们有一个名为范围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看到这个

PART 2

现在来到.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 

输出

唷!!!

Answer 2

此代码用名称创建工作簿的副本。然后，它会从该复制的工作簿中删除名称列表中的每个名称。它会计算工作簿之前和之后的公式错误的数量。如果错误计数相同，则不使用该名称。如果不同，则使用该名称。

我喜欢为像这样的复杂情况做这种测试。这意味着您不必太担心复杂的测试规则。你可以根据结果做出答案。

由于测试全部在副本上完成，因此应该是安全的。尽管如此，一定要保存所有的工作！

要使用，把放在一个工作簿的名称列表，并将其命名与列表“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个参数。

请注意，这只会检查工作簿级名称。如有必要，您可以添加对工作表级别的检查。

Answer 3

以下代码适用于我。有趣的点是

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