Pasar Access a excel mediante VB

Si ya tienes realizada la conexión con la base de datos de access, puedes generar una sentencia de extracción:
squery = "select * from mitabla"
Y después puedes utilizar el código siguiente:
Public Sub ExportaAExcel(rs As ADODB.Recordset, txtExcelTargetSpec As String, sSalida As String, sTipoReporte As String, sVariante As String)
On Error GoTo ErrHandler
Dim excelApp As Object
Dim excelBook As Object
Dim excelSheet As Object
Dim recCount As Long
Dim fldCount As Integer
Dim fldType As Long
Dim mValue As Variant
Dim startRow As Integer
Dim col As Integer
Dim row As Integer
Dim s As String
Dim i As Long
If Len(txtExcelTargetSpec) = 0 Then
MsgBox "Excel file spec not entered yet"
Exit Sub
ElseIf IsFileThere(App.Path & "\" & sSalida) Then
If MsgBox("El Archivo de Excel ya Existe. ¿ Se Sobreescribe ?", vbYesNo + vbQuestion) <> vbYes Then
Exit Sub
End If
End If
Screen.MousePointer = vbHourglass
If rs.EOF() And rs.BOF() Then
Screen.MousePointer = vbDefault
MsgBox "La consulta no tiene Datos"
Exit Sub
End If
rs.MoveLast
recCount = rs.RecordCount
rs.MoveFirst
fldCount = rs.Fields.Count
If fldCount = 0 Then
Screen.MousePointer = vbDefault
MsgBox "La consulta no tiene Datos"
Exit Sub
ElseIf recCount = 0 Then
Screen.MousePointer = vbDefault
MsgBox "La consulta no tiene Datos"
Exit Sub
End If
On Error Resume Next
Set excelApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set excelApp = CreateObject("Excel.Application")
End If
On Error GoTo ErrHandler
excelApp.Workbooks.Open FileName:=txtExcelTargetSpec
excelApp.Visible = True
Set excelBook = excelApp.Workbooks(1)
' Set excelBook = excelApp.Workbooks.Add
' Set excelSheet = excelBook.Worksheets(1)
If Val(excelApp.Application.version) >= 8 Then
Set excelSheet = excelApp.ActiveSheet
Else
Set excelSheet = excelApp
End If
' colocamos los títulos del reporte
' verificamos la empresa
If UCase$(Trim$(Cn.DefaultDatabase)) = "FACTURACION" Then
excelSheet.Cells(1, 2) = "metroscubicos.com"
Else
excelSheet.Cells(1, 2) = "ediciones m3.com"
End If
excelSheet.Cells(1, 12) = Format$(Date, "DD/MMM/YYYY")
' tipo de reporte
excelSheet.Cells(2, 2) = sTipoReporte
' variante
excelSheet.Cells(3, 2) = sVariante
startRow = 12
For row = 1 To recCount + 1
For col = 1 To fldCount
fldType = rs.Fields(col - 1).Type
' If IsFldTypeOKEdit(fldType) Then
mValue = rs.Fields(col - 1).value
excelSheet.Cells(startRow, col) = mValue
' End If
Next col
rs.MoveNext
startRow = startRow + 1
If rs.EOF() Then
rs.MoveFirst
Exit For
End If
Next row
If IsFileThere(App.Path & "\" & sSalida) Then
Kill App.Path & "\" & sSalida
End If
excelBook.saveas App.Path & "\" & sSalida
excelApp.Quit
Set excelSheet = Nothing
Set excelBook = Nothing
Set excelApp = Nothing
Screen.MousePointer = vbDefault
MsgBox "Consulta Exportada al Archivo: " & App.Path & "\" & sSalida
Exit Sub
ErrHandler:
Screen.MousePointer = vbDefault
MsgBox (Err.Number & " " & Err.Description)
End Sub
Y lo llamas de la siguiente forma:
Dim sQuery As String
Dim sCampos As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
If optSeleccion(1).value = True Then
sCampos = "IdFactura,convert(char(10),FechaRegistro,103),convert(char(10),FechaCancelacion,103),Nombre_Razon_Social,rtrim(Concepto) + ' ' + rtrim(Concepto1) + ' ' + rtrim(Concepto2),Monto,Descuento,Monto-Descuento,IVA,Total,Clave,FormaPago + ' ' + Banco,convert(char(10),FechaPago,103)"
End If
If optSeleccion(0).value = True Then
sCampos = "IdFactura,convert(char(10),FechaImpresion,103),convert(char(10),FechaCancelacion,103),Nombre_Comercial,rtrim(Concepto) + ' ' + rtrim(Concepto1) + ' ' + rtrim(Concepto2),Monto,Descuento,Monto-Descuento,IVA,Total,Clave,FormaPago + ' ' + Banco,convert(char(10),FechaPago,103)"
End If
'IdCliente
'IdUsuario
'NumFactura
'Pagado
'IdBanco
'IdFormaPago
'FechaPago
'PagaHastaFecha
'FechaRegistroCobranza
'FechaSistema
'NumReferencia
'IdClientes
'IdStatus
'IdGrupo
'IdDueno
'DigitoVerificador
'Licencia
'Nombre_Comercial
'RFC
'Domicilio_Fiscal
'Colonia
'CP
'Ciudad
'Contacto_Soporte
'IdEjecutivo
'Telefono
'Contacto_cobranza
'Fecha_Ingreso
'Email_Contacto1
'Email_Contacto2
'clave_m3
'domicilio_fiscal1
'comisionista_1
'comisionista_2
'comisionista_3
'FechaImpresion
sQuery = "SELECT "
If optSeleccion(1).value = True Then
If optOpciones(2).value = True Then
sQuery = sQuery & sCampos & " FROM vewPagosPendientes_DEB WHERE FechaRegistro >= '" & Format$(Me.DTPFechaInicio.value, "YYYYMMDD") & "' AND FechaRegistro <= '" & Format$(Me.DTPFechaFin.value, "YYYYMMDD") & "' order by nombre_comercial"
End If
End If
If optSeleccion(0).value = True Then
If optOpciones(2).value = True Then
sQuery = sQuery & sCampos & " FROM VewLstFacturas_DEB WHERE Pagado = 1 and Detalle='Correcta' AND FechaImpresion >= '" & Format$(Me.DTPFechaInicio.value, "YYYYMMDD") & "' AND FechaImpresion <= '" & Format$(Me.DTPFechaFin.value, "YYYYMMDD") & "' order by FechaImpresion desc"
End If
End If
'select * from VewLstFacturas where Pagado=1 and Detalle='Correcta' order by FechaImpresion desc
With rs
.ActiveConnection = Cn
.CursorLocation = adUseClient
.CursorType = adOpenForwardOnly
.LockType = adLockReadOnly
.Open sQuery
If Not .EOF Then
Call ExportaAExcel(rs, App.Path & "\machote.xls", "prueba.xls", Me.optSeleccion(1).Caption, Me.optOpciones(0).Caption)
End If
End With
rs.Close
Set rs = Nothing