我有几本包含3500多个命名范围的工作簿，其中大多数没有使用。为了清理混乱，我想运行一个删除所有未使用名称的宏。
以下宏似乎可以正常运行，但是运行大约需要半个小时。我实际上打开了状态栏，因此可以确定它仍在进行中。
我想获得有关如何更有效地完成此任务的建议。
Prelude> teste 5
3
答案 0 :(得分：2)
如上所述，请尝试一下。
将所有公式放入数组而不是命名范围。
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
可以用以下内容替换该循环，应该保存所有数据（...好吧，希望如此）。如果所有usedranges成功加载，那么遍历所有内容应该很容易。
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
答案 1 :(得分：1)
另一种替代方法是检查名称范围是否具有任何依赖项：
Function HasDependents(r As Range)
r.ShowDependents
HasDependents = r.Address(, , , 1) <> r.NavigateArrow(0, 1).Address(, , , 1)
r.ShowDependents 1
End Function
样品使用：
For Each xName In xWB.Names
If Not HasDependents(xName.RefersToRange) Then xName.Delete
Next
从技术上讲，这不会检查是否使用了名称，而是仅在使用了名称所指的范围时（假设所有名称均指范围）。 要遍历依赖项并检查其公式中是否包含名称，可以修改此示例： https://excelhelphq.com/how-to-find-all-dependent-cells-outside-of-worksheet-and-workbook-in-excel-vba/