CodigoVisualBasic para Controlar tiempo máximo de espera en consulta desde Excel a base datos Access

Justo hace un momento acabo de responder una pregunta que es muy parecida a la tuya.

No sé si te funcionará porque en la situación que tu describes exactamente no lo he probado.

Public Function EsperaUnPoco(NumSegundos As Variant)

Dim TiempoEspera As Variant, Inicio As Variant
On Error GoTo Err_EsperaUnpoco

TiempoEspera = NumSegundos
Inicio = Timer
Do While Timer < Inicio + TiempoEspera
DoEvents
Loop

'Aquí debes hacer el sondeo: Si se ha hecho el proceso, seguir

If .............. Then

'Nada

Else

MsgBox "................

End If

Exit_EsperaUnpoco:
Exit Function
Err_EsperaUnpoco:
MsgBox Err.Number & " - " & Err.Description
Resume Exit_EsperaUnpoco
End Function

En tu caso, el sondeo y mensaje debes hacerlo después del "Loop", con el If Then que te indico...

Y para llamar a la Función:

Call EsperaUnPoco(s) >> Siendo "s" el Numero de Segundos.

Gracias por responder...

Tengo una duda ,como colocarias tu funcion dentro una macro para realizar la consulta a la base de datos...

...y en caso que excel tarde mas de 10segundos se cancele la consulta?

Aca te dejo el codigo que utilizo para cargar la base datos en excel

------------------------------------------------------------------------------------------------------------

Sub actualizar_datos()

'CONEXION Y CONSULTA BASE DE DATOS
Dim path_Bd As String
Dim cnn As New ADODB.Connection
Dim recSet As New ADODB.Recordset
Dim strDB, strSQL As String
Dim strTabla As String
Dim lngCampos As Long
Dim i As Long
Dim bBien As Boolean
On Error GoTo ControlError
bBien = True
'CONECTAMOS CON LA BASE DE DATOS DE ACCESS Y ABRIMOS CONSULTA
path_Bd = ThisWorkbook.Path & "\database.accdb"
cnn.Provider = "Microsoft.ACE.OLEDB.12.0"
cnn.Properties("Data Source") = path_Bd
cnn.Properties("Jet OLEDB:Database Password") = ""
cnn.Open
strTabla = "BASE"
strSQL = "SELECT * FROM " & strTabla & " "
recSet.Open strSQL, cnn

'COPIAR LOS DATOS A LA HOJA
Worksheets("Hoja1").Select
'LIMPIAMOS DATOS DE EXCEL ANTES DE ACTUALIZAR
limpiardatos = Sheets("Hoja1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Hoja1").Range("A3:z" & limpiardatos).ClearContents
'GRABAMOS REGISTROS BASE DE DATOS DE ACCESS EN EXCEL
Sheets("Hoja1").Cells(3, 1).CopyFromRecordset recSet
'COPIAMOS RÓTULOS DE CAMPOS
lngCampos = recSet.Fields.Count
For i = 0 To lngCampos - 1
Sheets("Hoja1").Cells(2, i + 1).Value = recSet.Fields(i).Name
Next
'DESCONECTAMOS
recSet.Close: Set recSet = Nothing
cnn.Close: Set cnn = Nothing
Sheets("Hoja1").Select
MsgBox "LECTURA DE BASE DE DATOS ,EXITOSA!."
Salir:
If Not bBien Then
MsgBox "NO SE HA PODIDO CONECTAR A BASE DATOS" _

& ", INTÉNTALO MÁS TARDE."
End If
On Error Resume Next
recSet.Close: Set recSet = Nothing
cnn.Close: Set cnn = Nothing
Exit Sub
ControlError:
MsgBox Err.Number & " - " & Err.Description
bBien = False
Resume Salir

End Sub

------------------------------------------------------------------------------------------------------------

Y este otro codigo para realizar busquedas en la base datos Access:

------------------------------------------------------------------------------------------------------------

Sub BUSCAR()
Dim conn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim path_Bd As String
Dim strDB, strSQL As String
Dim strTabla As String
Dim i As Long
Dim bBien As Boolean
On Error GoTo ControlError
bBien = True
'CONECTAMOS CON LA BASE DE DATOS DE ACCESS Y ABRIMOS CONSULTA
path_Bd = ThisWorkbook.Path & "\database.accdb"
conn.Provider = "Microsoft.ACE.OLEDB.12.0"
conn.Properties("Data Source") = path_Bd
conn.Properties("Jet OLEDB:Database Password") = ""
conn.Open
strTabla = "BASE"
strSQL = "SELECT * FROM " & strTabla & " "
rst.Open strTabla, conn, adOpenKeyset, adLockOptimistic
'REVIZAMOS EXISTA UN TEXTO A BUSCAR
Dim VALOR123 As String
VALOR123 = "%" & CStr(Hoja1.Range("D1").Value) & "%"
If VALOR123 = "" Or Len(VALOR123) < 3 Then
MsgBox ("Escriba el nombre a buscar ,mayor a 3 caracteres")
GoTo desconectar
End If
'LIPIAMOS DATOS DE EXCEL ANTES DE ACTUALIZAR
limpiardatos = Sheets("Hoja1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Hoja1").Range("A3:z" & limpiardatos).ClearContents
'REALIZAMOS LA CONSULTA
Dim lngcampos, FIL: lngcampos = rst.Fields.Count: FIL = 2
rst.Find "NOMBRE LIKE " & VALOR123 & ""
Do Until rst.EOF
FIL = FIL + 1
For i = 0 To lngcampos - 1
Sheets("Hoja1").Cells(FIL, i + 1).Value = rst.Fields(i).Value
Next
rst.Find "NOMBRE LIKE " & VALOR123 & "", SkipRecords:=1, SearchDirection:=adSearchForward
Loop
'COPIAMOS RÓTULOS
For i = 0 To lngcampos - 1
Sheets("Hoja1").Cells(2, i + 1).Value = rst.Fields(i).Name
Next
desconectar:
rst.Close
Set rst = Nothing
conn.Close
Set conn = Nothing

Salir:
If Not bBien Then
MsgBox "NO SE HA PODIDO ACTUALIZAR LA BASE DE DATOS, INTÉNTALO MÁS TARDE."
End If
On Error Resume Next
recSet.Close: Set recSet = Nothing
cnn.Close: Set cnn = Nothing
Exit Sub
ControlError:
MsgBox Err.Number & " - " & Err.Description
bBien = False
Resume Salir
End Sub

------------------------------------------------------------------------------------------------------------

Pero la verdad no comprendo ,en que parte del codigo debo insertar tu funcion de tiempo y como cancelar la consulta en caso de que excel tarde más de 10segundos ,la base de datos contiene 10mil registros con 20columnas/campos

Se agradece cualquier sugerencia ,incluso si tengo que cambiar todo el  codigo.