查找大工作簿中使用命名范围的位置

Question

我有一个工作簿中有594个命名范围的列表,其中有近20页,每个工作表有大约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

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

第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

产量

唷!

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 参数。

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