Блог

Я получаю сообщение об ошибке как ошибка времени выполнения 7 при запуске утилиты очистки имен, как указано в приведенном ниже коде. Я использую жесткий диск объемом 512 ГБ, 8 ГБ оперативной памяти, процессор I7, поэтому проблем с памятью не должно быть, и все же проблема возникает.

В моей книге определено 123188 имен, которые я хочу удалить, используя приведенный ниже код. Есть ли способ повысить эффективность работы с кодом / у кого-нибудь есть код / встроенная надстройка, которую я могу включить в основную надстройку?

Функция прерывается при

Для каждого objName в ActiveWorkbook.Имена

Любая помощь будет оценена.

Заранее спасибо

     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 amp; " 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
    
  

Если итерация коллекции занимает слишком много памяти, вы можете вручную выбрать каждый элемент по одному. При удалении элементов важно работать в обратном направлении с конца, потому что при удалении элемента 1 элемент 2 становится элементом 1. Поэтому мы используем Step -1 для работы в обратном направлении.

Чтобы сделать ваше предложение guard понятным и избежать пустых Ifs, я изменил логику на 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 amp; " 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
  

ОБНОВЛЕНИЕ: добавлен код сохранения и изменено поведение удаления.

Попробуйте это. Подход, который я использовал, заключался в том, чтобы запускать цикл в обратном направлении снизу, чтобы Excel не перемещал элементы вверх каждый раз, когда они удаляются и удаляются через номер индекса, а не имя. Я также сделал тест немного более эффективным, я думаю.

 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

Это может быть так же просто, как отключить вычисления и обновления экрана… это должно повысить стабильность и значительно увеличить скорость.

Итак, перед вашим For…Следующий цикл —

 Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
  

Затем после вашего For …Следующий цикл —

 Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
  

Вам также следует рассмотреть возможность запуска этих последних двух строк после отслеживания любых ошибок, чтобы не оставлять настройки неактивными.

Вот дополнительная информация о сохранении, которую вы просили. Я не закодировал ваше решение, поскольку вы должны иметь возможность соответствующим образом изменить это. Это отсчитывается назад от 50 и сохраняется каждые 5 раз в цикле с помощью инструкции debug, чтобы вы могли видеть, что это работает.

 Sub quickSaveDemo()

Dim counter As Integer
counter = 50

For i = counter To 1 Step -1
    Debug.Print "Loop count - " amp; i amp; " - Other stuff here"
    If i Mod 5 = 0 Then
        Debug.Print "Save here"
        ActiveWorkbook.Save
    End If
Next i

End Sub