No puedo pasar a excel formulario filtrado de access
Estimados BUenas tardes tengo el siguiente código y no logro pasar a excel los datos filtrados.
Me. CtlTodos. SetFocus
On Error GoTo sol_err
'Declaramos las variables
Const nombreHoja As String = "CDatos"
Const nombreTabla As String = "DIPRDEP5"
Dim miExcel As Excel.Application
Dim rutaExcel As String
Dim i As Long, j As Long
Dim fld As Field
Dim rst As Recordset
Dim db As Database
Dim rsTmp As Recordset 'el recorset de la tabla temporal
Set db = CurrentDb
Set rsTmp = db.OpenRecordset("Select * From Tbl_Auxiliar", dbOpenDynaset)
Dim datosSQL As String
With Me.Form.RecordsetClone
.MoveFirst
Do Until .EOF
rsTmp.AddNew
rsTmp!Nombre_Apellidos = Me.Nombre_Apellidos
rsTmp!DNI = Me.DNI
rsTmp!FUNCION = Me.FUNCION
rsTmp!CATEGORIA = Me.CATEGORIA
rsTmp!Cargo = Me.Cargo
rsTmp!FECHA_INICIO = Me.FECHA_INICIO
rsTmp!FECHA_FINAL = Me.FECHA_FINAL
rsTmp!ART_114 = Me.ART_114
rsTmp!ART_115 = Me.ART_115
rsTmp!DIASFALTAS = Me.DIASFALTAS
rsTmp!RESTO114 = Me.RESTO114
rsTmp!RESTO115 = Me.RESTO115
rsTmp!DIAGNOSTICO = Me.DIAGNOSTICO
rsTmp!Dias = Me.Dias
rsTmp!Alta = Me.Alta
rsTmp!mira = Me.mira
rsTmp.Update
.MoveNext
Loop
End With
rutaExcel = Application.CurrentProject.Path & "\FALTA.xlsx"
'----------------------------------------------------------------------------------------------
' rutaExcel = "c:\MisExcel\DatosEnero\nombreExcel.xls"
'----------------------------------------------------------------------------------------------
'Creamos el recordset sobre la tabla
Set rst = CurrentDb.OpenRecordset(nombreTabla)
'Si no hay registros en la consulta salimos
If rst.RecordCount = 0 Then
MsgBox "No existen datos para exportar", vbExclamation, "SIN DATOS"
Exit Sub
End If
'Creo el objeto Excel
Set miExcel = CreateObject("Excel.Application")
'Lo hago no visible
miExcel.Visible = False
'Abro el Excel seleccionado
miExcel.Workbooks.Open rutaExcel, True, False
'Sitúo el cursor en el reloj de arena porque el proceso puede ser largo
DoCmd.Hourglass True
'Inicializamos i y j
i = 0
j = 0
'Nos movemos al primer registro
rst.MoveFirst
'Iniciamos el proceso
Do Until rst.EOF
miExcel.Worksheets(nombreHoja).Range("b12").Value = "OLAVARRIA (077)"
miExcel.Worksheets(nombreHoja).Range("d12").Value = "HELEN KELLER"
miExcel.Worksheets(nombreHoja).Range("j12").Value = "1299"
miExcel.Worksheets(nombreHoja).Range("O12").Value = Now
'miExcel.Worksheets(nombreHoja).Range("A16:S20000").ClearContents
'Recorremos los campos de la tabla o consulta
For Each fld In rst.Fields
miExcel.Worksheets(nombreHoja).Range("A16").Offset(i, j).Value = rst.Fields(fld.Name).Value
'Aumentamos una columna
j = j + 1
Next fld
'Aumentamos una fila
i = i + 1
'Reinicializamos j
j = 0
'Nos movemos al siguiente registro
rst.MoveNext
Loop
'Volvemos a situar el puntero en su posición normal
DoCmd.Hourglass False
'Lanzamos un mensaje de confirmación
MsgBox "Exportación realizada", vbInformation, "CORRECTO"
'Guardamos el Excel y lo cerramos
miExcel.ActiveWorkbook.Save
Salida:
miExcel.Workbooks.Close
miExcel.Application.Quit
Set miExcel = Nothing
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete From Tbl_Auxiliar"
Application.FollowHyperlink rutaExcel
Exit Sub
sol_err:
'Volvemos a situar el puntero en su posición normal
DoCmd.Hourglass False
'Gestionamos los errores error que pudieran producirse
Select Case Err.Number
Case 9 'No existe la hoja
MsgBox "La hoja no existe en el Excel", vbCritical, "ERROR"
Case 1004 'No existe el Excel
MsgBox "El Excel donde quiere exportar los datos no existe", _
vbCritical, "ERROR"
Case Else
MsgBox "Se ha producido el error " & Err.Number & " - " & Err.Description, _
vbCritical, "ERROR"
End Select
Resume Salida
1 Respuesta
No necesita crear la tabla temporal, para esto puede utilizar una magnifica función para exportar un recordset clonado de Daniel Pineault. Pienso que si las cosas ya existen y dan buen resultado para qué reinventar la rueda.
CÓDIGO DEL BOTÓN EXPORTAR RECORDSET
Copie este código en un módulo
'---------------------------------------------------------------------------------------
'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 FunctionSi quiere el ejemplo lo puede utilizar a [email protected] favor en el asunto anotar la consulta.
Estimado Eduardo, gracias por su consejo. Si ya lo tengo implementado en otra base.
Lo que necesito es pasar los datos a una hoja de excel en la cual ya están los datos predeterminados y a partir de la celda A16 se completa con los datos, que no puedo pasar filtrados.
Les envíe a su email, la base para que la vea.
Gracias Saludos
Le envíe a su email la respuesta.
