6

我在一个有近 20 张工作表的工作簿中有 594 个命名范围的列表，每张工作表有大约 200 列数据。我需要找出命名范围的使用位置，以便删除不相关的范围。我将命名范围的列表粘贴到工作表上，然后尝试通过记录它们来查找它们是否在公式中使用，然后在所有工作表和列中使用 find 方法。问题是尽管使用了查找 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
4

3 回答 3

5

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

第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看这个

在此处输入图像描述

第2部分

现在来到.Find. 我看到您在工作表中只搜索一次。因为你可以有很多场景中的单词Sid，你不能只有一个.Find。您将不得不使用.FindNext. 请参阅此链接以了解如何使用它。我已经在那里解释过了，所以我不会在这里解释。

我们可以.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

输出

在此处输入图像描述

呸！！！

于 2014-11-01T12:27:27.290 回答
2

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

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
于 2014-11-01T21:32:35.523 回答
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 参数。

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

于 2014-11-01T15:56:48.283 回答