Медленно выполняется удалённая выборка

Private Sub Кнопка80_Click()
    On Error GoTo ErrorHandler
    
    Dim startTime As Double
    Dim executionTime As String
    startTime = Timer ' Засекаем время начала выполнения
    
    Dim searchValue As String
    Dim searchField As String
    Dim ctrl As Control
    Dim conn As ADODB.Connection
    Dim cmd As ADODB.Command
    Dim rs As ADODB.Recordset
    Dim resultMsg As VbMsgBoxResult
    Dim recordCount As Integer
    Dim currentPosition As Integer
    Dim firstBookmark As Variant
    Dim connString As String
    
    ' Логирование начала выполнения
    Debug.Print "[" & Now & "] Начало выполнения макроса"
    
    
    Set ctrl = Screen.PreviousControl
    If ctrl Is Nothing Then
        executionTime = Format((Timer - startTime) / 86400, "hh:mm:ss")
        MsgBox "Не выбрано поле для поиска. Сначала кликните в нужное поле." & vbCrLf & _
               "Время выполнения: " & executionTime, vbExclamation, "Ошибка"
        Debug.Print "Ошибка: не выбрано поле для поиска"
        Exit Sub
    End If
    
    If Not (TypeOf ctrl Is TextBox Or TypeOf ctrl Is ComboBox) Then
        executionTime = Format((Timer - startTime) / 86400, "hh:mm:ss")
        MsgBox "Поиск возможен только по полям TextBox или ComboBox" & vbCrLf & _
               "Время выполнения: " & executionTime, vbExclamation, "Ошибка"
        Debug.Print "Ошибка: выбрано поле неподдерживаемого типа: " & TypeName(ctrl)
        Exit Sub
    End If
    
    searchField = ctrl.Name
    Debug.Print "Поле для поиска: " & searchField
    
    '  Запрос значения для поиска
    searchValue = InputBox("Введите точное значение для поиска в поле " & searchField, "Поиск")
    If searchValue = "" Then
        executionTime = Format((Timer - startTime) / 86400, "hh:mm:ss")
        Debug.Print "Поиск отменен пользователем. Время выполнения: " & executionTime
        Exit Sub
    End If
    
    Debug.Print "Ищем значение: " & searchValue
    
    '  Сохраняем текущую позицию
    On Error Resume Next
    firstBookmark = Me.Bookmark
    If Err.Number <> 0 Then
        Debug.Print "Не удалось сохранить текущую позицию: " & Err.Description
        firstBookmark = Null
    End If
    On Error GoTo ErrorHandler
    
    '  Подключение к SQL Server
    connString = "Driver={ODBC Driver 18 for SQL Server};" & _
                 "Server=;" & _
                 "Database=;" & _
                 "Uid=;" & _
                 "Pwd=;" & _
                 "Encrypt=yes;TrustServerCertificate=yes;"
    
    Debug.Print "Пытаюсь подключиться к базе данных..."
    
    Set conn = New ADODB.Connection
    conn.connectionString = connString
    conn.Open
    
    If conn.State <> adStateOpen Then
        executionTime = Format((Timer - startTime) / 86400, "hh:mm:ss")
        MsgBox "Не удалось подключиться к базе данных" & vbCrLf & _
               "Время выполнения: " & executionTime, vbCritical, "Ошибка"
        Debug.Print "Ошибка подключения к базе данных"
        GoTo CleanUp
    End If
    
    Debug.Print "Подключение успешно установлено"
    
    ' Создание и выполнение команды
    Set cmd = New ADODB.Command
    With cmd
        .ActiveConnection = conn
        .CommandText = "SELECT * FROM База_сотрудников WHERE [" & searchField & "] = ?"
        .CommandType = adCmdText
        .Parameters.Append .CreateParameter("@searchValue", adVarWChar, adParamInput, Len(searchValue), searchValue)
    End With
    
    Debug.Print "Выполняю SQL запрос: " & cmd.CommandText
    
    Set rs = New ADODB.Recordset
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    
    '  Проверка результатов
    If rs.BOF And rs.EOF Then
        executionTime = Format((Timer - startTime) / 86400, "hh:mm:ss")
        MsgBox "Совпадений не найдено для значения: " & searchValue & vbCrLf & _
               "Время выполнения: " & executionTime, vbInformation, "Результат"
        Debug.Print "Записей не найдено"
        GoTo CleanUp
    End If
    
    '  Подсчет записей
    rs.MoveLast
    recordCount = rs.recordCount
    rs.MoveFirst
    
    Debug.Print "Найдено записей: " & recordCount
    
    ' Отображение результатов
    currentPosition = 1
    Do Until rs.EOF
        ' Формируем условие поиска
        Dim searchCondition As String
        Dim fieldValue As Variant
        
        fieldValue = rs.Fields("Код").Value ' Предполагаем, что есть поле Код
        
        Debug.Print "Обрабатываю запись Код: " & fieldValue & " (" & currentPosition & "/" & recordCount & ")"
        
        ' Ищем запись в форме по Код
        Me.RecordsetClone.FindFirst "[Код] = " & fieldValue
        If Me.RecordsetClone.NoMatch Then
            Debug.Print "Запись Код " & fieldValue & " не найдена в форме"
        Else
            Me.Bookmark = Me.RecordsetClone.Bookmark
            Me.Refresh
            DoEvents
            
            Debug.Print "Отображаю запись Код: " & fieldValue
            
            executionTime = Format((Timer - startTime) / 86400, "hh:mm:ss")
            resultMsg = MsgBox("Найдена запись " & currentPosition & " из " & recordCount & vbCrLf & _
                             "Показать следующую запись?" & vbCrLf & _
                             "Время выполнения: " & executionTime, _
                             vbQuestion + vbYesNo, "Результат поиска")
            
            If resultMsg = vbNo Then Exit Do
        End If
        
        currentPosition = currentPosition + 1
        rs.MoveNext
    Loop
    
    If currentPosition > recordCount Then
        executionTime = Format((Timer - startTime) / 86400, "hh:mm:ss")
        MsgBox "Просмотрено все " & recordCount & " записей" & vbCrLf & _
               "Время выполнения: " & executionTime, vbInformation, "Завершено"
        Debug.Print "Все записи просмотрены"
    End If
    
CleanUp:
    ' Закрытие соединений
    On Error Resume Next
    If Not rs Is Nothing Then
        If rs.State = adStateOpen Then rs.Close
        Set rs = Nothing
    End If
    
    If Not cmd Is Nothing Then Set cmd = Nothing
    
    If Not conn Is Nothing Then
        If conn.State = adStateOpen Then conn.Close
        Set conn = Nothing
    End If
    
    executionTime = Format((Timer - startTime) / 86400, "hh:mm:ss")
    Debug.Print "[" & Now & "] Завершение выполнения макроса. Общее время: " & executionTime
    Exit Sub
    
ErrorHandler:
    executionTime = Format((Timer - startTime) / 86400, "hh:mm:ss")
    MsgBox "Произошла ошибка:" & vbCrLf & _
           "Номер: " & Err.Number & vbCrLf & _
           "Описание: " & Err.Description & vbCrLf & _
           "Модуль: " & Err.Source & vbCrLf & _
           "Время выполнения: " & executionTime, vbCritical, "Ошибка"
    
    Debug.Print "ОШИБКА [" & Now & "]: " & Err.Number & " - " & Err.Description & " в " & Err.Source & _
                ". Время выполнения: " & executionTime
    
    Resume CleanUp
End Sub