excel - VBA删除Excel中未使用的命名范围
问题描述
我有几个包含 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
解决方案
如上所述,请尝试一下。
将所有公式放入数组而不是命名范围。
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
推荐阅读
- python - 制作一个有周期表的程序
- spring-boot - 您可以使用地图而不是内存数据库来存储数据吗?
- android - 如何使用 Ionic Capacitor 打包托管 Web 应用程序
- sql - INSERT 查询在 SQL 视图上运行,但不在 Visual Basic 中
- html - 如何使输入与背景图像一起使用?
- c# - JsonConvert.DeserializeObject 在.net 中不起作用
- c# - 3-Tier - 模型重用?
- stripe-payments - Stripe Checkout 服务器端加载客户卡
- javascript - 使用 NodeJS 通过 LDAP 身份验证获取用户个人资料图片
- java - MismatchedInputException - Jackson 反序列化