VBA Access Медленно выполняется процедура импорта

[Ethex]

Доброго времени суток
Не знаю насколько это имеет отношение к проблеме, однако в начале прошлой недели на работе сбоило электричество. С тех самых пор я стал
замечать, что процедуры импорта, которые я пишу для форм, выполняются неприлично медленно.
В данный момент имеется форма с опцией выбора нескольких файлов и кнопки для импорта таблиц excel разного типа. Сейчас гоняю импорт таблицы где строк под импорт смешное колличество - 10 (импорт занял 7 минут, при том, что импорт той же таблицы штатным методом происходит мгновенно).
В чём может быть причина?
Используемый код:
- Импорт

Public Sub ImpChFv()
Dim appX As Excel.Application
Dim wB As Excel.Workbook
Dim wS As Excel.Worksheet
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim rsE As DAO.Recordset
Dim i As Long

Set appX = CreateObject("Excel.Application")
Set wB = appX.Workbooks.Open(Forms![Project].[Поле12].Value)
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("Таблица")
Set wS = wB.Sheets(1)
   With wS
      For i = 3 To .Rows.Count
         If Len(wS.Cells(i, "B")) > 0 Then
            With rst
            .AddNew
            On Error GoTo ErN
            ![ob] = wS.Cells(i, "A")
            ![naim] = wS.Cells(i, "B")
            ![cod_pogruzka] = wS.Cells(i, "C")
            ![cod_razgruzka] = wS.Cells(i, "D")
            On Error GoTo 0
            .Update
            End With
         End If
      Next
   End With
rst.Close: Set rst = Nothing
dbs.Close: Set rst = Nothing
wB.Close: Set wB = Nothing
appX.Quit: Set appX = Nothing

MsgBox "блабла"

   If DCount("[Name]", "MSysObjects", "[Name] = 'Errors_×àñòü5'") > 0 Then
   MsgBox "блабла"
   End If
Exit Sub
ErN:
   Select Case Err.Number
   Case 3421:
      If DCount("[Name]", "MSysObjects", "[Name]='Errors'") = 0 Then
      CurrentDb.Execute "CREATE TABLE Errors(RowNumbers INT)"
      End If
   Set rsE = dbs.OpenRecordset("Errors")
      With wS
         With rsE
         .AddNew
         ![RowNumbers] = wS.Cells(i, "A")
         .Update
         End With
      End With
   rsE.Close: Set rsE = Nothing
   Resume Next
   End Select
End Sub

- Поиск повторов значений одного из полей

Public Sub ChFvRep()

   If DCount("[Name]", "MSysObjects", "[Name] = 'Повторы'") > 0 Then
   CurrentDb.Execute "DROP TABLE Повторы"
   End If
   
CurrentDb.Execute "CREATE TABLE Повторы ([ob] VARCHAR)"
CurrentDb.Execute "INSERT INTO Повторы ([ob]) SELECT [ob] FROM ÔÅÐ_×àñòü5"
CurrentDb.Execute "DELETE [ob] FROM [Повторы] WHERE [ob] IN(SELECT [ob] FROM [Повторы] GROUP BY [ob] HAVING COUNT (*) = 1)"
   
   If DCount("*", "Повторы") = 0 Then
   CurrentDb.Execute "DROP TABLE Повторы"
   MsgBox "Повторов не найдено"
   Exit Sub
   End If
   
   If DCount("[Name]", "MSysObjects", "[Name] = Повторы'") > 0 Then
   MsgBox "Найдены повторы"
   End If
End Sub

- Кнопка на форме

Private Sub Кнопка34_Click()

If IsNull(Forms![Project].[Поле12].Value) Then
   MsgBox "Файл не выбран"
   Exit Sub
   End If
   
On Error GoTo ErS
CurrentDb.Execute "CREATE TABLE Таблица ([ob] VARCHAR, [naim] MEMO, [cod_pogruzka] FLOAT, [cod_razgruzka] FLOAT)"

   If DCount("[Name]", "MSysObjects", "[Name] = 'Errors'") > 0 Then
   CurrentDb.Execute "DROP TABLE Errors5"
   End If
Call ImpChFv
Call ChFvRep
Exit Sub
ErS:
   Select Case Err.Number
   Case 3010:
   MsgBox "Таблица уже существует"
   Exit Sub
   End Select
End Sub

Ранее мне не приходилось работать с такими маленькими таблицами. Импортировал этой процедурой таблицы с более 100 килостроками. Да, не мгновенно, однако время было более-менее адекватное для такого объёма. Уж не знаю сколько теперь будет выполняться импорт таких таблиц, если так долго идёт десятистрочная.

Формат файла акса - mdb, эксельник - xlsx
Библиотеки:
Visual Basic For Applications
Microsoft Access 14.0 Object Library
OLE Automation
Microsoft Office 14.0 Access database engine Object Library
Microsoft ActiveX Data Objects 2.8 Library
Microsoft Visual Basic for Applications Extensibility 5.3
Microsoft Word 14.0 Object Library
Microsoft Office 14.0 Object Library
Microsoft Excel 14.0 Objects Library
Microsft ActiveX Data Objects 2.8 Library
Microsft ActiveX Data Objects Recordset 2.8 Library

На других машинах пока не запускал. Проверю вечером на домашнем ноуте в случае если к тому времени вопрос не будет исчерпан

[Aleksandr H.]

Размер mdb? Зжатие базы не помогает?

[Ethex]

Размер mdb? Зжатие базы не помогает?

До сжатия 1,73 мб, после 432 кб
Сжимал через Параметры - Сжимать при закрытии

Пару раз попробовал импортнуть - 6 мин.

[Aleksandr H.]

Еще вариант - пересоздать xlsx файла. Не сохранить как, а нового

[Ethex]

Сообщение от Aleksandr H.

пересоздать xlsx файла

Создал файлик с 10 строчками - 6 - 7 мин
Поставил на свой страх и риск импортаться книгу с овер 150 килостроками - 20-25 примерно минут, точно не засёк. Хотя по логике должно быть непойми сколько...

[Aleksandr H.]

Ручная трассировка где показывает задержку выполнения?

[Ethex]

Протрассировал.
Когда заканчиваются непустые строки, выполнение начинает долго прыгать по строкам кода

If Len(wS.Cells(i, "B")) > 0 Then

End If

Next

Минуя With. Похоже, условие проверяет все ячейки указанных столбцов на листе. Но если убрать условие - тогда хренелион пустых ячеек портнётся в аксесс.

Заменить If на Do While?

[Aleksandr H.]

а такая замена?

....
With wS
      For i = 3 To .Rows.Count
         If Len(wS.Cells(i, "B")) > 0 Then
....

==>

....
With wS
      For i = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
         If Len(wS.Cells(i, "B")) > 0 Then
....

[Ethex]

Сообщение от Aleksandr H.

а такая замена?

10строчная влетела мгновенно. Та, что большая импортнулась примерно в 1,5 раза быстрее.
Как называется этот метод?

Сообщение от Aleksandr H.

.Cells(.Rows.Count, "B").End(xlUp).Row

Хочу понять его получше

[Aleksandr H.]

"найти последнюю непустую ячейку столбца В, при условии что нету фильтров, и получить номер строки этой ячейки"