Exportar un su formulario de access a excel

La respuesta que da el sabio es ineficiente y torpe desde todo punto de vista, utilizo para estos casos una función excelente para exportar recordset clonado en formulario o subformulario. Elaborada por Daniel Pineault, CARDA Consultants Inc., está diseñada para pasarle varios parámetros opcionales como:

- Ruta del archivo y nombre a usar

- Nombre de la hoja de trabajo para actualizar, si se proporciona el libro y la hoja no existe, será
creada.

- Número de columna para comenzar a insertar los datos

- Número de fila para comenzar a insertar los datos

- Ajustar automáticamente la columna al ancho de los datos

- Congelar la fila del encabezado

FORMULARIO

Le muestro el resultado de 2 formas de llamar la función:

Resultado de llamar la función sin pasar ningún parámetro. Observe que aparece como título Libro1. Ejemplo de llamada:

Call ExportRecordset2XLS(Me.RecordsetClone)

En este caso le pasé a la función 2 parámetros, la ruta y nombre del libro, y, nombre de la hoja.

Ejemplo de llamada:

Call ExportRecordset2XLS(Me.RecordsetClone, CurrentProject.Path & "\ejemploExcel.xlsx", "ejeExcel")

Copie y pegue este código en un módulo.

Código de la función.

Option Compare Database
Option Explicit
'---------------------------------------------------------------------------------------
'Procedimiento: ExportRecordset2XLS
'Autor: Daniel Pineault, CARDA Consultants Inc.
'Sitio web: http://www.cardaconsultants.com
'Propósito: exportar el conjunto de registros pasado a Excel
'Copyright: Lo siguiente es una publicación como Attribution-ShareAlike 4.0 International
'(CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
'
'Variables de entrada:
'~~~~~~~~~~~~~~~~
'rs: objeto Recordset para exportar a Excel
'sFile: Opcional -> Ruta del archivo y nombre a usar
'Si no se proporciona ninguno, se crea un nuevo archivo de Excel
'sWrkSht: Opcional -> Nombre de la hoja de trabajo para actualizar
'Si se proporciona sWrkSht y la hoja no existe, será
'                   creado
'lStartCol: Opcional -> Número de columna para comenzar a insertar los datos en
'Si no hay suministro, la insersión comenzará en la 1ra columna
'lStartRow: Opcional -> Número de fila para comenzar a insertar los datos en
'Si no hay suministro, la insersión comenzará en la 1ra fila
'bFitCols: Opcional -> Ajustar automáticamente la columna al ancho de los datos contenidos en
'El valor predeterminado es verdadero
'bFreezePanes: Opcional -> Congelar la fila del encabezado
'El valor predeterminado es verdadero
'bAutoFilter: Opcional -> AutoFilter los datos
'El valor predeterminado es verdadero
'
' Ejemplo de llamada:
' ~~~~~~
' Call ExportRecordset2XLS(Me.RecordsetClone)
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2017-Mar-13             Initial Release
' 2         2017-Mar-16             Added sFile
'                                   Added sWrkSht
'                                   Added lStartCol
'                                   Added lStartRow
'                                   Added bFitCols
'                                   Added bFreezePanes
'                                   Added bAutoFilter
' 2         2018-09-20              Updated Copyright
'---------------------------------------------------------------------------------------
Function ExportRecordset2XLS(ByVal rs As DAO.Recordset, _
                             Optional ByVal sFile As String, _
                             Optional ByVal sWrkSht As String, _
                             Optional ByVal lStartCol As Long = 1, _
                             Optional ByVal lStartRow As Long = 1, _
                             Optional bFitCols As Boolean = True, _
                             Optional bFreezePanes As Boolean = True, _
                             Optional bAutoFilter As Boolean = True)
    '#Const EarlyBind = True    'Use Early Binding, Req. Reference Library
    #Const EarlyBind = False    'Use Late Binding
    #If EarlyBind = True Then
        'Early Binding Declarations
        Dim oExcel            As Excel.Application
        Dim oExcelWrkBk       As Excel.WorkBook
        Dim oExcelWrkSht      As Excel.WorkSheet
    #Else
        'Late Binding Declaration/Constants
        Dim oExcel            As Object
        Dim oExcelWrkBk       As Object
        Dim oExcelWrkSht      As Object
        Const xlCenter = -4108
    #End If
    Dim bExcelOpened          As Boolean
    Dim iCols                 As Integer
    Dim lWrkBk                As Long
    'Start Excel
    On Error Resume Next
    Set oExcel = GetObject(, "Excel.Application")    'Bind to existing instance of Excel
    If Err.Number <> 0 Then    'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo Error_Handler
        Set oExcel = CreateObject("Excel.Application")
        bExcelOpened = False
    Else    'Excel was already running
        bExcelOpened = True
    End If
    On Error GoTo Error_Handler
    oExcel.ScreenUpdating = False
    oExcel.Visible = False   'Keep Excel hidden until we are done with our manipulation
    If sFile <> "" Then
        Set oExcelWrkBk = oExcel.Workbooks.Open(sFile)    'Start a new workbook
        On Error Resume Next
        lWrkBk = Len(oExcelWrkBk.Sheets(sWrkSht).Name)
        If Err.Number <> 0 Then
            oExcelWrkBk.Worksheets.Add.Name = sWrkSht
            Err.Clear
        End If
        On Error GoTo Error_Handler
        Set oExcelWrkSht = oExcelWrkBk.Sheets(sWrkSht)
        oExcelWrkSht.Activate
    Else
        Set oExcelWrkBk = oExcel.Workbooks.Add()    'Start a new workbook
        Set oExcelWrkSht = oExcelWrkBk.Sheets(1)
        If sWrkSht <> "" Then
            oExcelWrkSht.Name = sWrkSht
        End If
    End If
    With rs
        If .RecordCount <> 0 Then
            .MoveFirst    'This is req'd, had some strange behavior in certain instances without it!
            'Build our Header
            '****************
            For iCols = 0 To rs.Fields.Count - 1
                oExcelWrkSht.Cells(lStartRow, lStartCol + iCols).Value = rs.Fields(iCols).Name
            Next
            'Format the header
            With oExcelWrkSht.Range(oExcelWrkSht.Cells(lStartRow, lStartCol), _
                                    oExcelWrkSht.Cells(lStartRow, lStartCol + iCols - 1))
                .Font.Bold = True
                .Font.ColorIndex = 2
                .Interior.ColorIndex = 1
                .HorizontalAlignment = xlCenter
            End With
            'Copy the data from our query into Excel
            '***************************************
            oExcelWrkSht.Cells(lStartRow + 1, lStartCol).CopyFromRecordset rs
            'Some formatting to make things pretty!
            '**************************************
            'Freeze pane
            If bFreezePanes = True Then
                oExcelWrkSht.Cells(lStartRow + 1, 1).Select
                oExcel.ActiveWindow.FreezePanes = True
            End If
            'AutoFilter
            If bAutoFilter = True Then
                oExcelWrkSht.Rows(lStartRow & ":" & lStartRow).AutoFilter
            End If
            'Fit the columns to the content
            If bFitCols = True Then
                oExcelWrkSht.Range(oExcelWrkSht.Cells(lStartRow, lStartCol), _
                                   oExcelWrkSht.Cells(lStartRow, lStartCol + iCols)).EntireColumn.AutoFit
            End If
            'Start at the top
            oExcelWrkSht.Cells(lStartRow, lStartCol).Select
        Else
            MsgBox "There are no records returned by the specified queries/SQL statement.", _
                   vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with"
            GoTo Error_Handler_Exit
        End If
    End With
Error_Handler_Exit:
    On Error Resume Next
    oExcel.Visible = True   'Make excel visible to the user
    Set rs = Nothing
    Set oExcelWrkSht = Nothing
    Set oExcelWrkBk = Nothing
    oExcel.ScreenUpdating = True
    Set oExcel = Nothing
    Exit Function
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: ExportRecordset2XLS" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function

No dices si el archivo Excel ya está creado o quieres que te lo cree. Así que voy a suponer que ya está creado y se llama Yasmin.xlsx. Y como no quiero complicarte la vida con mucho código...

Yo tengo una tabla Ventas y otra DetalleVenta relacionadas por Idventa y con ellas tengo hecho un formulario con subformulario, como en la imagen

Con la tabla DetalleVenta(la del subformulario) creo una consulta de creación de tabla a la que voy a llamar Aux, como en la imagen

De forma que cuando en cualquier registro pulso el botón

En este caso, el código del botón es

Private Sub Comando52_Click()
DoCmd.SetWarnings False
DoCmd.OpenQuery "consulta1"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "aux", "c:\users\gonza\documents\borrar\yasmin.xlsx", True
DoCmd.DeleteObject acTable, "aux"
End Sub

Es decir

1º Lo de Docmd. Setwarnings es para que no aparezca lo de Va a crear...

2º Abre(ejecuta, ya que es una consulta de acción) la consulta1, con lo cual crea la tabla aux sólo con los registros del subformulario

3º Envía a Excel los datos a la hoja Aux

4º Elimina la tabla Aux para que pueda repetir el proceso.

Como esta página ya no avisa de la petición de ampliación de información, si quisieras preguntar algo, casi mejor que me envíes un mensaje (sólo el mensaje) a [email protected] avisándome, o por si quisieras el ejemplo.