Exportar a Excel en una búsqueda

Sandro: Al filtrar los datos debes tener algo así como:

Me.ListaX.RowSource = “SELECT…………………….

Si eso esa sí haz lo siguiente:

1.- En la cabecera del Módulo de código del Formulario que muestras, y lógicamente fuera de cualquier Procedimiento o Función, declara una variable de Tipo String que puedes llamar por ejemplo QryResult

Quedaría

Dim QryResult As String

2.- Casi seguro que tendrás un Procedimiento en el AfterUpdate de ese cuadro de Texto >> de Buscar.

Al final del Procedimiento e inmediatamente antes del End Sub pones >>

QryResult = Me.ListaX.RowSource

ListaX será el nombre que debes sustituir por el que tu tengas

3.- Ahora viene la parte de Exportar a Excel mediante un Botón que para el código le llamaré >>BtnExportResultAExcel

En el Evento Click pones éste código: Si lo copias recuerda activar el Evento

Private Sub BtnExportResultAExcel_Click()
Dim StrSQL As String  'Sera QryResult
Dim StrQry As String
Dim db As DAO.Database
Dim Qdf As DAO.QueryDef
Dim RutaExport As String
Dim NombFichero As String
StrSQL = QryResult 'Nombre de la Consulta capturada como RowSorce del Cuadro de Lista
StrQry = "QryTmp"  'Nombre que le daremos a la Consulta para Exportar
RutaExport = CurrentProject.Path
NombFichero = RutaExport & "/" & StrQry & ".xlsx"
Set db = CurrentDb
Set Qdf = db.CreateQueryDef(StrQry, StrSQL)
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, StrQry, NombFichero, True
DoCmd.DeleteObject acQuery, StrQry
Set db = Nothing
End Sub

Como Ruta para la Exportación he puesto donde se encuentra la Base de Datos y como nombre del Fichero le he adjudicado el Nombre de la Consulta StrQry que como ves es QryTmp. Tu pones lo que se adapte a tus necesidades. También tendrás que adaptar el >>

AcSpreadsheetTypeExcel12Xml a tu versión de Access. Este está hecho en Access 2016

Un saludo >> Jacinto

Buenas Jacinto,

Tengo que decirte que eres un máquina!! Con respecto a tus preguntas, si, tengo un Rowsoruce en el código para los cuadros de lista y un afterupdate en el cuadro de texto (Donde busco la oficina).

Debo indicarte que el código lo he aplicado tal cual, cambiando lógicamente el nombre de la lista y del formato de Excel, pero me salía un error que solventé activando la librería ADO (No estaba activa).

Ahora me sale el siguiente error:

Si le digo "Depurar", me señala la siguiente línea de código.

¿Es posible que me falta alguna librería por activar? ¿O he cometido algún fallo al aplicar el código?

Nuevamente mil gracias por toda la ayuda prestada.

Sandro: Primero de todo comentarte que la librería que tienes que activar no es la de ADO, sino la de DAO, que tiene un Nombre de >>

Microsoft Office xx.0 Access database engine Object Library

La xx dependerá de la Versión de Access que tengas. Para 2016 es 16

En teoría no se debe presentar ese error que comentas, porque el Código destruye la Consulta StrQry que genera la QryTmp. Puede que se haya interrumpido el código y la consulta se queda construida.

Para una rápida solución mira en el panel de Navegación de la Izquierda de Access.

Ponlo de modo que te muestre todos los Objetos y en el apartado consultas, verás esa creada.

Borrala y rueda el código y me cuentas. Ahora ando un poco liado, pero miraré de hacer un hueco para prevenir esa eventualidad. El código no es muy complejo y te lo pondré aquí.

Un saludo >> Jacinto

Buenas Jacinto

He realizado lo que me has dicho, he eliminado la consulta del panel de navegación y he vuelto a ejecutar el código.

Ahora me dice lo siguiente:

Y me señala esta línea de código:

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, StrQry, NombFichero, True

La librería la he conseguido activar quitando antes la de ADO. Y aún así sigue fallando en ese punto 🤔😢😢😖

No te preocupes Jacinto, cuando tengas un hueco lo miramos. No es urgente.

Gracias por todo de verdad.

Sandro: La exportación la debes hacer inmediatamente después de haber filtrado, para que la variable >> QryResult no esté vacía y recuerda que la debes declarar a nivel del Módulo del Formulario, tal como te indicaba en mi primera respuesta. Un saludo >> Jacinto

Sandro: Espero que ya te funcione como pretendíamos.

Las modificaciones que te comentaba son:

Del Código que ya tienes pasa a >>

Private Sub BtnExportResultAExcel_Click()
Dim StrSQL As String  'Sera QryResult
Dim StrQry As String
Dim db As DAO.Database
Dim Qdf As DAO.QueryDef
Dim RutaExport As String
Dim NombFichero As String
StrSQL = QryResult 'Nombre de la Consulta capturada como RowSorce del Cuadro de Lista
StrQry = "QryTmp"  'Nombre que le daremos a la Consulta para Exportar
RutaExport = CurrentProject.Path
NombFichero = RutaExport & "/" & StrQry & ".xlsx"
'Sondeo si por alguna maniobra se ha quedado creada y sin Borrar la Consulta >> "QryTmp" -----
ObjetoDestino = "QryTmp"
Call ExisteObjeto(ObjetoDestino)
If Existe = True And EsConsulta = True Then
        DoCmd.DeleteObject acQuery, StrQry
Else
        Set db = CurrentDb
        Set Qdf = db.CreateQueryDef(StrQry, StrSQL)
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, StrQry, NombFichero, True
        DoCmd.DeleteObject acQuery, StrQry
        Set db = Nothing
End If
End Sub

Como complemento a éste código, en un Modulo Estandar que tengas y si no lo tienes lo creas nuevo con el Nombre que a ti te parezca más adecuado, pones ésto otro.

Option Compare Database  'Esta línea debe generarse sola al crear el Módulo
Option Explicit
Public ObjetoDestino As String
Public Objeto As Object
Public Existe As Boolean
Public EsConsulta As Boolean
Public EsTabla As Boolean
Function ExisteObjeto(NombreObjeto As String)
Existe = False
EsConsulta = False
EsTabla = False
For Each Objeto In CurrentDb.QueryDefs
        If NombreObjeto = LCase(Objeto.Name) Then
                Existe = True
                EsConsulta = True
                Exit For
        End If
Next
If Not Existe Then
        EsConsulta = False
        For Each Objeto In CurrentDb.TableDefs
                If NombreObjeto = LCase(Objeto.Name) Then
                        Existe = True
                        EsTabla = True
                        Exit For
                End If
        Next
End If
End Function ' ExisteObjeto

Como puedes apreciar te valdrá para saber si existe un Objeto y si es Tabla o Consulta.

Lo puedes usar en otras aplicaciones o en esa que ya tienes, para otros sondeos.

Un saludo >> Jacinto

Buenas tardes Jacinto,

Perdón por la demora. He estado revisado, corrigiendo y aplicando el código pero no funciona. Además, creo que en algún punto me he perdido porque me parece extraño.

1º He activado la librería ADO como me dijiste.

2º En el formulario búsqueda, fuera de cualquier parámetro o función, he añadido esto Dim QryResult As String.

3º He creado el botón Exportar y le he añadido el segundo código que me has enviado (Private Sub BtnExportResultAExcel_Click)

4º He creado un nuevo módulo, que lo he llamado objeto y le he añadido el tercer código que me has enviado (Public ObjetoDestino As String).

Con respecto a tu tercer comentario (Sandro: La exportación la debes hacer inmediatamente...), no termino de entender donde debo añadirla ni como.

Por lo demás, creo que ya esta todo añadido... ¿O me sigue faltando algo?

Perdona las molestias pero no soy muy bueno en programación, y me cuesta a veces comprender un poco todo esto.

Gracias por todo.

Sandro: Dos cuestiones previas y me comentas.

1.- La librería que yo te comenté no es ADO >> Es DAO

2.- Cambia el Nombre del Módulo a otro que no sea Objeto. Ejemplo MdlObjeto

Si aún así te sigue el fallo envíame si quieres tu BD a mi correo que ya tienes y le doy una mirada.

Mis saludos >> Jacinto

Buenas Jacinto,

Cierto, es la librería DAO la que tengo activa. Siempre me lío con las abreviaturas...

Te reenvio la base de datos con la búsqueda. Si falla algo te pido disculpas, ya que he tenido que eliminar varias líneas de código que no puedo compartir.

http://www.mediafire.com/file/637ysla8wc6cdzj/BBDDSedesSandroModif.zip/file

Muchas gracias por todo.

Sandro: Al código en principio le falta la línea >>

QryResult = Me.ListaDatos.RowSource

Que tal como te comenté va al final del Procedimiento >>

Private Sub Busca_AfterUpdate() y justo antes de la línea final de End Sub

Le seguiré dando una ojeada, para ver si hay alguna otra cuestión y tu haces pruebas entre tanto.

Dime por favor la versión de Access que usas. Un saludo >> Jacinto