New issue - runtime error - Out of Memory - excel

Question

I am getting an error as Runtime error 7 while running the cleanup names utility as mentioned in code below. I am using 512 GB HDD, 8 GB RAM, I7 processor so should not be a memory issue and still the issue pops up.
My workbook has 123188 defined names which I want to delete using the code below. Is there a way to be more efficient with the code / does someone has a code / built in addin which I can incorporate in a master addin?
The function breaks at
For Each objName In ActiveWorkbook.Names
Any help will be appreciated.
Thanks in advance
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

If iterating the collection is taking up too much memory you can manually select each item one by one. When deleting items it's important to work backwards from the end because when you delete item 1 then item 2 becomes item 1. So we use Step -1 to work backwards.
To make your guard clause read plainly and avoid empty Ifs I changed the logic to If Not And. I find this more clear. Don't use underscore _ in method names because that is reserved for Event methods.
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
UPDATE: Added the save code and changed the delete behavior.

Answer 2

Try this. The approach I took was to run a loop backwards from the bottom so that excel doesn't move the items up each time one is deleted and deleting via Index number rather than name. I also made the test a little more efficient I think.
Option Explicit
Sub DeleteNames()
Dim NameCount As Long
Dim Cntr As Long
Dim WkBk As Workbook
Dim TestName As String
Set WkBk = ThisWorkbook
NameCount = ActiveWorkbook.Names.Count
'Delete names
With WkBk
For Cntr = NameCount To 1 Step -1
On Error Resume Next 'not sure you need this but can't hurt
TestName = UCase(.Names(Cntr).NameLocal)
If InStr(TestName, "DATABASE") > 0 Or _
InStr(TestName, "DB") > 0 Then
'If database - no action
Else
.Names(Cntr).Delete
End If
Next Cntr
End With 'WkBk
End Sub
HTH

Answer 3

It may be as simple as turning off calculation and screen updates... this should increase stability and greatly increase speed.
So, before your For...Next loop -
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Then after your For...Next loop -
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
You should also consider running those last two lines after trapping any errors so that you don't leave the settings inactive.

Answer 4

Here is the extra bit about saving you asked for. I haven't coded up your solution as you should be able to modify this accordingly. This counts backwards from 50 and saves every 5 times through the loop with a debug statement so you can see that it works.
Sub quickSaveDemo()
Dim counter As Integer
counter = 50
For i = counter To 1 Step -1
Debug.Print "Loop count - " & i & " - Other stuff here"
If i Mod 5 = 0 Then
Debug.Print "Save here"
ActiveWorkbook.Save
End If
Next i
End Sub