Private Sub AccessExcell_Click()
Dim H As Long
Dim V As Long
Dim MiBase As Database
Dim MiTabla As Recordset
On Error GoTo ErrorExcel
Dim objExcel As Excel.Application
'Set MiBase = OpenDatabase(CurrentProject.Path & "\db1.mdb")
'Esta linea anterior, por si deseamos abrir una tabla de cualquier
'otra MDB. En este ejemplo abrimos una tabla Local (Datos).
Set MiBase = CurrentDb
Set MiTabla = MiBase.OpenRecordset("SELECT * FROM Datos ORDER BY Nombre ASC", dbOpenDynaset)
If MiTabla.RecordCount = 0 Then
MsgBox "La base de datos esta vacia", vbCritical + vbOKOnly, "AVISO"
Exit Sub
End If
Set objExcel = New Excel.Application
objExcel.Visible = True
'determina el numero de hojas que se mostrara en el Excel
objExcel.SheetsInNewWorkbook = 1
'Crea el Libro
objExcel.Workbooks.Add
With objExcel.ActiveSheet
.Range(.Cells(1, 1), .Cells(1, 4)).Borders.LineStyle = xlContinuous
.Cells(3, 1) = "NOMBRE"
.Cells(3, 2) = "DIRECCION"
.Cells(3, 3) = "POBLACION"
.Cells(3, 4) = "CANTIDAD"
.Range(.Cells(3, 1), .Cells(3, 4)).Font.Bold = True
.Columns("D").HorizontalAlignment = xlHAlignRight
.Columns("A").ColumnWidth = 30
.Columns("B").ColumnWidth = 30
.Columns("C").ColumnWidth = 30
.Columns("D").ColumnWidth = 15
End With
objExcel.ActiveSheet.Cells(1, 1) = "BASE DE DATOS de ACCESS A EXCEL"
objExcel.ActiveSheet.Range(objExcel.ActiveSheet.Cells(1, 1), objExcel.ActiveSheet.Cells(1, 4)).HorizontalAlignment = xlHAlignCenterAcrossSelection
With objExcel.ActiveSheet.Cells(1, 1).Font
.Color = vbRed
.Size = 14
.Bold = True
End With
V = 4
H = 1
Do While Not MiTabla.EOF
DoEvents
objExcel.ActiveSheet.Cells(V, H) = MiTabla.Fields!nombre
objExcel.ActiveSheet.Cells(V, H + 1) = MiTabla.Fields!Direccion
objExcel.ActiveSheet.Cells(V, H + 2) = MiTabla.Fields!Poblacion
objExcel.ActiveSheet.Cells(V, H + 3) = MiTabla.Fields!Cantidad
V = V + 1
MiTabla.MoveNext
Loop
V = V + 3
objExcel.Range(objExcel.Cells(V, 1), objExcel.Cells(V, 4)).Borders.LineStyle = xlContinuous
objExcel.ActiveSheet.Range(objExcel.ActiveSheet.Cells(V, 1), objExcel.ActiveSheet.Cells(V, 4)).HorizontalAlignment = xlHAlignCenterAcrossSelection
objExcel.ActiveSheet.Cells(V, 1) = "Francisco Javier García Aguado: Código Web del Programador"
MiBase.Close
Set objExcel = Nothing
Exit Sub
ErrorExcel:
MsgBox "Ha ocurrido un error de conexión con Excel." _
& Chr(13) & Chr(13) & "Error : " & Err.Number _
& Chr(13) & "Info : " & Err.Description _
& Chr(13) & "Objeto : " & Err.Source _
& Chr(13) & Chr(13) & "Revisa las referencias y la ruta de la base de datos. ", vbCritical, "Paco Avisa: Error al conectar con Excel"
End Sub
               (
geocities.com/es/ensolva/Descargas)                   (
geocities.com/es/ensolva)                   (
geocities.com/es)