RV: Crear hojas Excel

'****** Crear Hoja Excel

'******************************

Dim H As Long

Dim V As Long

Dim MiBase As Database

Dim MiTabla As Recordset

Dim objExcel As Excel.Application

On Error GoTo ErrorExcel

'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 (Excel).

Set MiBase = CurrentDb

Set MiTabla = MiBase.OpenRecordset(SQL)

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 = False 'Ocultamos la aplicación excell

objExcel.SheetsInNewWorkbook = 1 'determina el numero de hojas

‘que se mostrara en el Excel

objExcel.Workbooks.Add 'Crea el Libro

With objExcel.ActiveSheet 'cogemos la hoja activa de Excel

'Definimos un rango y pintamos una linea alrededor

.Range(.Cells(1, 1), .Cells(1, 4)).Borders.LineStyle = xlContinuous

'Llenamos celdas con texto fijo

.Cells(3, 1) = "ANO"

.Range(.Cells(3, 1), .Cells(3, 13)).Font.Bold = True ' definimos un rango

‘y ponemos el texto en negrita

‘Definimos formato de columnas

.Columns("D").HorizontalAlignment = xlHAlignRight

.Columns("A").ColumnWidth = 30

.Columns("B").ColumnWidth = 30

.Columns("C").ColumnWidth = 30

.Columns("D").ColumnWidth = 15

.Columns("E").NumberFormat = "dd/mm/yyyy"

.Columns("M").NumberFormat = "dd/mm/yyyy"

End With

objExcel.ActiveSheet.Cells(1, 1) = "Titulo de Cabecera"

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!ANO_PRESUP

objExcel.ActiveSheet.Cells(V, H + 1) = MiTabla.Fields!campo1

objExcel.ActiveSheet.Cells(V, H + 2) = MiTabla.Fields!campo2

‘……………………………………………………………………

objExcel.ActiveSheet.Cells(V, H + 11) = MiTabla.Fields!campoN

MiTabla.Edit

MiTabla.Fields![Fecha de asignación] = Date

MiTabla.Update

objExcel.ActiveSheet.Cells(V, H + 12) = MiTabla.Fields![Fecha de asignación]

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) = "Fec: Código Web del Programador"

objExcel.DisplayAlerts = False

Fecha = Replace(Date, "/", "_")

Filename = "Tareas_" & Fecha

objExcel.ActiveWorkbook.SaveAs Filename, , , , , , , xlLocalSessionChanges

objExcel.ActiveWorkbook.Close

MiBase.Close

objExcel.Quit

Set objExcel = Nothing

Me.Estado.Caption = "Se ha creado el fichero "

MsgBox ("Se ha creado el fichero ")

Me.Estado.Caption = ""

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