Sub ExportaExcel(ByVal strSQL As String, strFilename As String, ByVal pasos As Integer, Optional strSheetName As String = "", Optional boShExcel As Boolean) '----------------------------------------------------------------------------------------------------------------------------------------------- ' Fuente : '----------------------------------------------------------------------------------------------------------------------------------------------- ' Título : ExportaExcel ' Autor : Alba Salvá ' Fecha : no se acuerda, pero hace mucho tiempo ' Propósito : Copia el contenido de un objeto Recordset ADO o DAO en una hoja de Excel ' Retorno : Sin retorno ' Argumento/s : La sintaxis del procedimiento consta del siguiente argumento: ' Parte Modo Descripción '----------------------------------------------------------------------------------------------------------------------------------------------- ' strSQL Obligatorio Datos que vamos a exportar a Excel ' strFilename Obligatorio Nombre del fichero de destino de los datos ' pasos Obligatorio Indica la cantidad de registros a insertar de cada vez, ' aumentar o disminuir en función de la velocidad de la red. ' strSheetName Opcional Nombre de la hoja ' boShExcel Opcional Activar/desactivar propiedades de la hoja que se abre '----------------------------------------------------------------------------------------------------------------------------------------------- ' Referencias : https://docs.microsoft.com/en-us/office/vba/api/excel.range.copyfromrecordset ' Importante : Copia el contenido de un objeto Recordset ADO o DAO en una hoja de Excel, comenzando en la esquina superior izquierda ' del rango especificado. Si el objeto Recordset contiene campos con objetos OLE y campos multivalor, este método falla. '----------------------------------------------------------------------------------------------------------------------------------------------- ' Test: : Copiar el bloque siguiente al portapapeles y pega en el editor de VBA. Descomentar la línea que nos interese ' 'Sub ExportaExcel_test() 'Dim strSQL As String, StrRuta As String 'Dim pasos As Integer ' 'strSQL = "SELECT tabla.campo1, tabla.campo2, tabla.campo3, tabla.campo4, tabla.campo5 " & _ ' "FROM tabla;" ' 'StrRuta = Application.CurrentProject.Path & "\Exportar_test.xlsx" ' 'Call ExportaExcel(strSQL, StrRuta, 20, ,True) ' 'Exit sub '----------------------------------------------------------------------------------------------------------------------------------------------- Dim Rs As DAO.Recordset Dim xlapp As Excel.Application Dim wb As Excel.Workbook Dim ws As Excel.Worksheet Dim iCols As Integer Dim ahora As Single Dim fso As Scripting.FileSystemObject Dim autoName As Boolean Dim n As Long Dim sig As Integer, Contador As Integer 'Las líneas comentadas pertenecen a los controles del test que hemos realizado 'Dim StartTime As Double, EndTime As Double On Error GoTo lbError 'Comprueba que no exista el fichero y si existe, lo borra Set fso = New Scripting.FileSystemObject If fso.FileExists(strFilename) Then fso.DeleteFile strFilename, True End If 'Abre el recordset que le hemos pasado Set Rs = CurrentDb.OpenRecordset(strSQL) 'Recupera el total de registros que se van a trasnferir If Not (Rs.BOF And Rs.EOF) Then DoEvents Rs.MoveLast sig = Rs.RecordCount Rs.MoveFirst End If autoName = True 'Crea un nuevo objeto Excel Set xlapp = New Excel.Application 'Aplica las propiedades según el parámetro boShExcel que le hemos pasado With xlapp .DisplayStatusBar = boShExcel .EnableEvents = boShExcel .DisplayAlerts = boShExcel .Visible = boShExcel End With 'Añade un nuevo libro Set wb = xlapp.workbooks.Add 'Borra todas las hojas del nuevo libro excel, excepto 1 While wb.sheets.Count > 1 wb.sheets(wb.sheets.Count).Delete Wend 'Crea el ojeto hoja Set ws = wb.sheets(1) 'Cambia el nombre de la hoja If strSheetName <> "" Then ws.Name = Trim(Left(strSheetName, 31)) ElseIf autoName Then ws.Name = Trim(Left(fso.GetBaseName(strFilename), 31)) End If 'Crea la primera línea como cabecera con los nombres de los campos For iCols = 0 To Rs.Fields.Count - 1 DoEvents ws.Cells(1, iCols + 1).Value = Rs.Fields(iCols).Name Select Case Rs.Fields(iCols).Type Case dbDate ws.Columns(iCols + 1).NumberFormat = "dd/mm/yyyy hh:mm:ss" Case dbDecimal ws.Columns(iCols + 1).NumberFormat = "0" Case Else ws.Columns(iCols + 1).NumberFormat = "@" End Select Next DoEvents 'Recorre el recordset y va enviando los paquetes de datos según el rango que hemos marcado según el parámetro pasos If Not (Rs.BOF And Rs.EOF) Then Rs.MoveFirst ' Debug.Print Time For n = 1 To sig Step pasos ' StartTime = Timer DoEvents Contador = Contador + 1 If boShExcel Then xlapp.ScreenUpdating = False ws.Range("A" & n + 1).CopyFromRecordset Rs, pasos If n = 1 Then xlapp.ScreenUpdating = True End If 'EndTime = Timer ' 'Debug.Print "20 registros: " & FormatNumber((EndTime - StartTime), 2, vbFalse, vbFalse, vbFalse) & "s" ' 'Debug.Assert Not Contador = 5 Next ws.Range("A" & sig).Select End If 'Ejecuta algunos arreglos estéticos como "TableStyle" ws.ListObjects.Add(xlSrcRange, ws.UsedRange, , xlYes).Name = "Tabla1" ws.ListObjects("Tabla1").TableStyle = "TableStyleMedium2" For iCols = 0 To Rs.Fields.Count - 1 DoEvents 'Cambia los formatos Select Case Rs.Fields(iCols).Type Case dbDate ws.Columns(iCols + 1).NumberFormat = "dd/mm/yyyy hh:mm:ss" End Select ws.Cells(1, iCols + 1).Select 'Autoajusta las columnas ws.Columns(iCols + 1).EntireColumn.AutoFit Next If boShExcel Then xlapp.ScreenUpdating = True ws.Cells(1, 1).Select With xlapp .DisplayStatusBar = boShExcel .EnableEvents = boShExcel .DisplayAlerts = boShExcel .ScreenUpdating = boShExcel End With ws.Cells(1, 1).Select 'Graba el fichero wb.SaveAs FileName:=strFilename GoTo lbFinally lbError: MsgBox Err & vbCrLf & Error$ Resume 'Cierra todos los objetos lbFinally: On Error Resume Next Rs.Close Set Rs = Nothing Set ws = Nothing wb.Close Set wb = Nothing xlapp.Quit Set xlapp = Nothing On Error GoTo 0 End Sub