Как можно ускорить поиск в dbf файле ~250000 строк - VB

Dim strcon2 As String
            Dim strsql2 As String
            Dim cn2 As ADODB.Connection
            Dim rs2 As ADODB.Recordset
            Dim spv As String
            Dim npv As String
            Dim timef As Date
            nLen = Len(Target.Value)
            If (nLen >= 10) Then
                npv = Right(Target.Value, 6)
                spv = Left(Target.Value, nLen - 6)
                strcon2 = "Driver={Microsoft Visual FoxPro Driver};UID=;SourceType=DBF;Exclusive=No;Background-dFetch=Yes;Collate=Russian;Null=No;Deleted=Yes;SourceDB=c:\xx\Basa;"
                Set cn2 = New ADODB.Connection
                cn2.ConnectionString = strcon2
                cn2.Open
                strsql2 = "select R24, R25, R26 from vxxx.dbf where r55='" & spv & "' and r56='" & npv & "'"
                Set rs2 = New ADODB.Recordset
                
                timef = Time()
                rs2.Open strsql2, cn2, adOpenKeyset, adLockOptimistic
                timef = Time() - timef
                Application.StatusBar = "Готово. Время выполнения: " & timef

                Do Until rs2.EOF
                    Cells(Target.Row, 10).Value = Trim(rs2.Fields("R24").Value)
                    Cells(Target.Row, 11).Value = Trim(rs2.Fields("R25").Value)
                    Cells(Target.Row, 12).Value = Trim(rs2.Fields("R26").Value)
                    rs2.MoveNext
                Loop
                rs2.Close
                cn2.Close
                Set rs2 = Nothing
                Set rs2 = Nothing
            End If

Private Sub Workbook_Open()
    Dim ConnectionString2 As String
    Dim SQLString2 As String
    Dim TimeFlag As Date
    
    ConnectionString2 = "Driver={Microsoft Visual FoxPro Driver};UID=;SourceType=DBF;Exclusive=No;Background-dFetch=Yes;Collate=Russian;Null=No;Deleted=Yes;SourceDB=c:\xx\Basa;"
    SQLString2 = "select R24, R25, R26, R55, R56 from vxxx.dbf order by r55, r56"
    Set rs2 = New ADODB.Recordset
    
    Application.DisplayStatusBar = True
    Application.StatusBar = "Открываем набор записей!"
    Application.ScreenUpdating = False
                
    TimeFlag = Time()
    With rs2
        .CursorType = adOpenKeyset
        .LockType = adLockReadOnly
        .Open SQLString2, ConnectionString2, adCmdText
    End With
    TimeFlag = Time() - TimeFlag
                
    Application.StatusBar = "Время открытия набора записей: " & TimeFlag
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If (Target.Count = 1) Then
        If (Target.Column = 14 And Target.Value <> "") Then
            Dim spv As String
            Dim npv As String
            Dim timef As Date
            nLen = Len(Target.Value)
            If (nLen >= 10) Then
                npv = Right(Target.Value, 6)
                spv = Left(Target.Value, nLen - 6)

                timef = Time()    
                rs2.Filter = "r55='" & spv & "' AND r56='" & npv & "'"
                timef = Time() - timef
                
                Application.StatusBar = "Готово. Время выполнения: " & timef
                Application.ScreenUpdating = True
                'MsgBox rs2.GetString
                Do Until rs2.EOF
                    Cells(Target.Row, 10).Value = Trim(rs2.Fields("R24").Value)
                    Cells(Target.Row, 11).Value = Trim(rs2.Fields("R25").Value)
                    Cells(Target.Row, 12).Value = Trim(rs2.Fields("R26").Value)
                    rs2.MoveNext
                Loop
            End If
        End If
    End If
End Sub