excel - 新问题 - 运行时错误 - 内存不足

Question

我在运行下面代码中提到的清理名称实用程序时收到运行时错误 7 错误。我使用的是 512 GB 硬盘、8 GB RAM、I7 处理器，所以不应该是内存问题，但问题仍然会出现。
我的工作簿有 123188 个定义的名称，我想使用下面的代码删除它们。有没有办法提高代码效率/有人有代码/内置插件，我可以将其合并到主插件中？
该功能在

For Each objName In ActiveWorkbook.Names

任何帮助将不胜感激。
提前致谢

    Option Explicit

Sub Cleanup_names123()
'
'Deletes all names except for Print_Area, Database, and DB

'Declare variables
Dim objName As Name
Dim strAnswer As String

'Display instructions
strAnswer = MsgBox("This function will delete all named ranges except Print_Area, DB, and Database. If you are not ready to proceed click Cancel to exit.", vbOKCancel)
'If cancelled - exit function
If strAnswer = vbCancel Then End

'If no names found, exit
If ActiveWorkbook.Names.Count = 0 Then
    MsgBox "No names found. Macro complete."
    End
End If

MsgBox ActiveWorkbook.Names.Count & " name(s) found. It may take a few minutes for the cleanup."

'Delete names
For Each objName In ActiveWorkbook.Names
    On Error Resume Next
    If InStr(objName.Name, "Database") <> 0 Then
        'If Database - no action
    ElseIf InStr(objName.Name, "database") <> 0 Then
        'If database - no action
    ElseIf InStr(objName.Name, "DB") <> 0 Then
        'If database - no action
    Else
        objName.Delete
        ThisWorkbook.Names(objName.Name).Delete
    End If
Next

On Error GoTo 0

End Sub
    

Answer 1

如果迭代集合占用太多内存，您可以手动逐个选择每个项目。删除项目时，从最后开始倒退很重要，因为当您删除项目 1 时，项目 2 将变为项目 1。所以我们使用 Step -1向后工作。
为了让你的保护条款读起来清楚并避免空的 If，我将逻辑更改为 If Not And .我觉得这更清楚。不要使用下划线 _在方法名称中，因为这是为事件方法保留的。

Option Explicit

Public Sub CleanupNames()
    '
    'Deletes all names except for Print_Area, Database, and DB

    'Declare variables
    Dim strAnswer As String

    'Display instructions
    strAnswer = MsgBox("This function will delete all named ranges except Print_Area, DB, and Database. If you are not ready to proceed click Cancel to exit.", vbOKCancel)
    'If cancelled - exit function
    If strAnswer = vbCancel Then Exit Sub
    
    Dim NamesCount As Long
    NamesCount = ActiveWorkbook.Names.Count
    
    'If no names found, exit
    If NamesCount = 0 Then
        MsgBox "No names found. Macro complete."
        Exit Sub
    End If

    MsgBox NamesCount & " name(s) found. It may take a few minutes for the cleanup."

    'Delete names
    Dim iter As Long
    For iter = NamesCount To 1 Step -1
        Dim objName As String
        objName = ActiveWorkbook.Names.Item(iter).Name
        
        On Error Resume Next
        If Not InStr(objName, "Database") <> 0 And _
           Not InStr(objName, "database") <> 0 And _
           Not InStr(objName, "DB") <> 0 Then
           
            ActiveWorkbook.Names(objName).Delete
        End If
        
        If iter Mod 5000 = 0 Then ActiveWorkbook.Save
    Next iter
End Sub

更新:添加了保存代码并更改了删除行为。