excel - VBA删除Excel中未使用的命名范围

Question

我有几个工作簿，其中包含 3,500 多个命名范围，其中大部分未使用。为了清理困惑，我想运行一个宏来删除所有未使用的名称。

下面的宏似乎可以工作，但是运行大约需要半个小时。我实际上打开了状态栏，这样我就可以确定它仍在进行中。

我想获得有关如何更有效地完成这项任务的建议。

Sub DeleteUnusedNames()
'PURPOSE:   Delete named ranges that are not used in formulas in the active workbook

    Dim xWB As Workbook:    Set xWB = ActiveWorkbook
    Dim xWS As Worksheet
    Dim xNameCount As Long  'Count of all named ranges
    Dim xCount As Long      'Count of current range - used to track progress
    Dim xFound As Long      'Count of times a named range was used in a formula - moves on to next code when > 0
    Dim xDeletedCount As Long
    Dim xName As Name

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    On Error Resume Next

    xNameCount = xWB.Names.count

    For Each xName In xWB.Names
        If xName.Name Like "*Print_*" Then  'Skip Print Areas and Print Titles
        Else
            xFound = 0
            xCount = xCount + 1
            Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")"

            For Each xWS In xWB.Worksheets
                If xWS.Name Like "Workbook Properties" Then 'Don't search the Workbook Properties tab for Names (if this tab exists, it will not have any used names)
                Else
                    xFound = xFound + xWS.UsedRange.Find(What:=xName.Name, _
                        LookIn:=xlFormulas, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False, _
                        SearchFormat:=False).count
                    If xFound > 0 Then Exit For   'Name was found. Stop looking.
                End If
            Next xWS

            If xFound = 0 Then  'Name was not found in a formula on any of the worksheets
                xName.Delete
                xDeletedCount = xDeletedCount + 1
            End If
        End If
    Next xName

    If xMsg = "" Then
        MsgBox "No unused names were found in the workbook", , "No named ranges were deleted"
    Else
        MsgBox xDeletedCount & " names were deleted", , "Unused named ranges were deleted"
    End If

    Application.StatusBar = False

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Answer 1

如上所述，请尝试一下。

将所有公式放入数组而不是命名范围中。

Sub DeleteUnusedNames()
'PURPOSE:   Delete named ranges that are not used in formulas in the active workbook

    Dim xWB As Workbook:    Set xWB = ActiveWorkbook
    Dim xWS As Worksheet
    Dim xNameCount As Long  'Count of all named ranges
    Dim xCount As Long      'Count of current range - used to track progress
    Dim xFound As Long      'Count of times a named range was used in a formula - moves on to next code when > 0
    Dim xDeletedCount As Long
    Dim xName As Name
    Dim arrData As Variant  'an array to hold all formulas
    Dim R As Long, C As Long    'rows/columns

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    On Error Resume Next

    xNameCount = xWB.Names.Count

    For Each xName In xWB.Names
        If xName.Name Like "*Print_*" Then  'Skip Print Areas and Print Titles
        Else
            xFound = 0
            xCount = xCount + 1
            Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")"

            For Each xWS In xWB.Worksheets
                If xWS.Name Like "Workbook Properties" Then 'Don't search the Workbook Properties tab for Names (if this tab exists, it will not have any used names)
                Else
                    arrData = xWS.UsedRange.Formula

                    For R = LBound(arrData) To UBound(arrData)
                        For C = LBound(arrData, 2) To UBound(arrData, 2)
                            If InStr(1, arrData(R, C), xName.Name) > 0 Then
                                xFound = 1
                                Exit For
                            End If
                        Next C
                        If xFound > 0 Then Exit For
                    Next R
                End If
            Next xWS

            If xFound = 0 Then  'Name was not found in a formula on any of the worksheets
                xName.Delete
                xDeletedCount = xDeletedCount + 1
            End If
        End If
    Next xName

    If xMsg = "" Then
        MsgBox "No unused names were found in the workbook", , "No named ranges were deleted"
    Else
        MsgBox xDeletedCount & " names were deleted", , "Unused named ranges were deleted"
    End If

    Application.StatusBar = False

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

End Sub

可以用下面的循环替换该循环，应该保存所有数据(......好吧，希望如此)。如果所有使用的范围加载成功，那么循环遍历所有内容应该是轻而易举的事。

    Dim Z As Long
    Dim arrWholeData() As Variant: ReDim arrWholeData(xWB.Worksheets.Count)

    For Z = 1 To xWB.Worksheets.Count
        arrWholeData(Z) = xWB.Worksheets(Z).UsedRange.Formula
    Next Z

    For Each xName In xWB.Names
        If xName.Name Like "*Print_*" Then  'Skip Print Areas and Print Titles
        Else
            xFound = 0
            xCount = xCount + 1
            Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")"

            For Z = 1 To xWB.Worksheets.Count
                For R = LBound(arrWholeData(Z)) To UBound(arrWholeData(Z))
                    For C = LBound(arrWholeData(Z), 2) To UBound(arrWholeData(Z), 2)
                        If InStr(1, arrWholeData(Z)(R, C), xName.Name) > 0 Then
                            xFound = 1
                            Exit For
                        End If
                    Next C
                    If xFound > 0 Then Exit For
                Next R
                If xFound > 0 Then Exit For
            Next Z

            If xFound = 0 Then  'Name was not found in a formula on any of the worksheets
                xName.Delete
                xDeletedCount = xDeletedCount + 1
            End If
        End If
    Next xName

编辑:添加了替代方案。

编辑:最终完整代码:

Sub DeleteUnusedNames()
'PURPOSE:   Delete named ranges that are not used in formulas in the active workbook

    Dim startTime As Single, endTime As Single
    startTime = Timer

    Dim xWB As Workbook:    Set xWB = ActiveWorkbook
    Dim xNameCount As Long: xNameCount = xWB.Names.count
    Dim xCount As Long      'Count of current range - used to track progress
    Dim xFound As Long      'Count of times a named range was used in a formula - moves on to next code when > 0
    Dim xDeleted As Long    'Count of deleted named ranges
    Dim xArrWholeData() As Variant: ReDim xArrWholeData(xWB.Worksheets.count)
    Dim xRow As Long        'Row number
    Dim xCol As Long        'Column number
    Dim xName As Name       'Used for looping through names
    Dim xWSNum As Long      'Used for looping through worksheets
    Dim xNName As String    'Name of current named range in the loop - used for comparing

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    On Error Resume Next

    For xWSNum = 1 To xWB.Worksheets.count
        xArrWholeData(xWSNum) = xWB.Worksheets(xWSNum).UsedRange.Formula
    Next xWSNum

    For Each xName In xWB.Names
        xNName = xName.Name
        xCount = xCount + 1

        If xCount Mod 50 = 0 Then
            endTime = Timer
            Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")   " & (endTime - startTime) & " seconds have passed"
        End If

        If xNName Like "*Print_*" Then   'Skip Print Areas and Print Titles
        Else
            xFound = 0

            For xWSNum = 1 To xWB.Worksheets.count
                If xWB.Worksheets(xWSNum).Name Like "Workbook Properties" Then   'Skip the Workbook Properties worksheet
                Else
                    For xRow = LBound(xArrWholeData(xWSNum)) To UBound(xArrWholeData(xWSNum))
                        For xCol = LBound(xArrWholeData(xWSNum), 2) To UBound(xArrWholeData(xWSNum), 2)
                            If InStr(1, xArrWholeData(xWSNum)(xRow, xCol), xNName) > 0 Then
                                xFound = 1  'Name was found
                                GoTo NextName  'Stop looking for this name and go to the next name
                            End If
                        Next xCol
                    Next xRow
                End If
            Next xWSNum

            If xFound = 0 Then  'Name was not found in a formula on any of the worksheets
                xDeleted = xDeleted + 1
                xName.Delete
            End If
        End If

NextName:
    Next xName

    endTime = Timer
    Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")   " & (endTime - startTime) & " seconds have passed"

    If xDeleted = 0 Then
        MsgBox "No unused names were found in the workbook", , "No named ranges were deleted"
    Else
        MsgBox xDeleted & " names were deleted:", , "Unused named ranges were deleted"  'Removed & vbCr & xMsg before the first comma
    End If

    Application.StatusBar = False

    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

End Sub