Ejercicio práctico 9: Cómo imprimir informes automáticamente usando VBA en Excel.

imprimir-vba-excel

Escrito por Administrador

25 de agosto de 2021

Durante las últimas lecciones. hemos aprendido a elaborar y enviar informes por correo de manera automática. Hoy, además, vamos a imprimir automáticamente una selección de datos de una hoja Excel usando código VBA.

Para ello, he modificado la tabla de la hoja informe y he introducido registros con distintas fechas.

total-operaciones-matematicas-macros

Después del envío de emails, filtraremos la tabla del Grupo 1 por la última fecha que contenga, y enviaremos dichos registros directamente a la impresora.

Aunque este ejercicio esté desmenuzado en varias macros para que se vea más claro, tú puedes incluir todo el código en una sola y asignarle un solo botón. Así, se elaborará el informe, se enviará por correo y se imprimirá con un solo click.

A continuación, adjunto el código VBA para generar los informes, enviarlos por email e imprimir la selección de la hoja Excel. Las cinco primeras macros son exactamente las mismas que las del ejercicio práctico anterior.

Macro 1. Generar informes de materiales según grupo de trabajo.

Sub Informe()

'Desactivamos el refresco de pantalla para agilizar la macro

Application.ScreenUpdating = False

'Buscamos la última fila con datos de cada hoja

Sheets("Grupo 1").Select

filagrupo1 = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

Sheets("Grupo 2").Select

filagrupo2 = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

Sheets("Grupo 3").Select

filagrupo3 = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

'Recorremos los registros de la tabla y repartiéndolos en el resto de hojas en función del grupo de trabajo

Sheets("Informe").Select

f = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row

For i = 2 To f

Sheets("Informe").Select

'Si pertenece al GRUPO 1

If Cells(i, "K") = 1 Then

Range(Cells(i, "A"), Cells(i, "K")).Select

Selection.Copy

Sheets("Grupo 1").Select

Cells(filagrupo1, "A").Select

Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks _
:=False, Transpose:=False

filagrupo1 = filagrupo1 + 1

goto salto

End If

'Si pertenece al GRUPO 2

If Cells(i, "K") = 2 Then

Range(Cells(i, "A"), Cells(i, "K")).Select

Selection.Copy

Sheets("Grupo 2").Select

Cells(filagrupo2, "A").Select

Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks _
:=False, Transpose:=False

filagrupo2 = filagrupo2 + 1

goto salto

End If

'Si pertenece al GRUPO 3

If Cells(i, "K") = 3 Then

Range(Cells(i, "A"), Cells(i, "K")).Select

Selection.Copy

Sheets("Grupo 3").Select

Cells(filagrupo3, "A").Select

Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks _
:=False, Transpose:=False

filagrupo3 = filagrupo3 + 1

End If

salto:

Next

'Calculamos el importe total de cada grupo, dos filas más abajo del último registro

'GRUPO 1

Sheets("Grupo 1").Select

totalizar = Application.WorksheetFunction.Sum(Range(Cells(2, "E"), Cells(filagrupo1, "E")))

Cells(filagrupo1, "E") = totalizar

Cells(filagrupo1, "E").Select

With Selection

.HorizontalAlignment = xlCenter

End With

Selection.Font.Bold = True

'GRUPO 2

Sheets("Grupo 2").Select

totalizar = Application.WorksheetFunction.Sum(Range(Cells(2, "E"), Cells(filagrupo2, "E")))

Cells(filagrupo2, "E") = totalizar

Cells(filagrupo2, "E").Select

With Selection

.HorizontalAlignment = xlCenter

End With

Selection.Font.Bold = True

'GRUPO 3

Sheets("Grupo 3").Select

totalizar = Application.WorksheetFunction.Sum(Range(Cells(2, "E"), Cells(filagrupo3, "E")))

Cells(filagrupo3, "E") = totalizar

Cells(filagrupo3, "E").Select

With Selection

.HorizontalAlignment = xlCenter

End With

Selection.Font.Bold = True

'Llamamos a la macro para ordenar el informe

Call Ordenfinal

'Abrimos la hoja Grupo 1

Sheets("Informe").Select

'Activamos el refresco de pantalla

Application.ScreenUpdating = True

End Sub

Macro 2. Borrar informes de materiales.

Sub Borrar()

'Desactivamos el refresco de pantalla para agilizar la macro

Application.ScreenUpdating = False

'Mostramos mensaje de aviso porque se borrarán datos

resultado = MsgBox("¿Seguro? Se perderán los cálculos", vbYesNo + vbExclamation, "Advertencia")

Select Case resultado

Case vbNo:

GoTo final

End Select

'Borramos los datos de las hojas de Grupos

Sheets("Grupo 1").Activate

Range("A2:K500").ClearContents

Sheets("Grupo 2").Activate

Range("A2:K500").ClearContents

Sheets("Grupo 3").Activate

Range("A2:K500").ClearContents

'Volvemos a la hoja Informe

Sheets("Informe").Activate

final:

'Desactivamos el refresco de pantalla para agilizar la macro

Application.ScreenUpdating = True

End Sub

Macro 3. Ordenar informes según importe descendente.

Sub Ordenfinal()

'Ordenamos las hojas de los grupos por el campo importe, de mayor a menor

'GRUPO 1

Sheets("Grupo 1").Select

filagrupo1 = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row

Range(Cells(2, "A"), Cells(filagrupo1, "K")).Sort Key1:=Range("E:E"), Order1:=xlDescending, Header:=xlNo

'GRUPO 2

Sheets("Grupo 2").Select

filagrupo2 = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row

Range(Cells(2, "A"), Cells(filagrupo2, "K")).Sort Key1:=Range("E:E"), Order1:=xlDescending, Header:=xlNo

'GRUPO 3

Sheets("Grupo 3").Select

filagrupo3 = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row

Range(Cells(2, "A"), Cells(filagrupo3, "K")).Sort Key1:=Range("E:E"), Order1:=xlDescending, Header:=xlNo

'Abrimos la hoja Grupo 1

Sheets("Grupo 1").Select

End Sub

Macro 4. Crear automáticamente archivos y llamar a la función de envío de correos automáticos (Lotus).

Sub Enviar()

'Macro para la creación de archivos individuales por grupo y envío de la información

'Desactivamos el refresco de pantalla

Application.ScreenUpdating = False

Dim wrkNuevo As Workbook

Dim hojasActual As Long

'Creamos un libro nuevo GRUPO 1

'Elegimos una sola hoja

Application.SheetsInNewWorkbook = 1

'Creamos el libro

Set wrkNuevo = Workbooks.Add

ActiveWorkbook.SaveAs Filename:="C:\Grupo1.xls", FileFormat:= _
xlNormal, CreateBackup:=False

'Copiamos la hoja del Grupo 1

Workbooks(1).Worksheets(2).Copy After:=Workbooks(2).Worksheets(1)

Set Nombre = Worksheets(2)

Nombre.Name = "Grupo 1"

Application.DisplayAlerts = False

Worksheets("Hoja1").Delete

Application.DisplayAlerts = True

'Vamos cerrando

Cells(1, 1).Select

ActiveWindow.ScrollRow = Cells(1, "A").Row

ActiveWindow.ScrollColumn = Cells(1, "A").Column

Application.DisplayAlerts = False

Workbooks("Grupo1.xls").Close Savechanges:=True

Application.DisplayAlerts = True

'Creamos un libro nuevo GRUPO 2

'Elegimos una sola hoja

Application.SheetsInNewWorkbook = 1

'Creamos el libro

Set wrkNuevo = Workbooks.Add

ActiveWorkbook.SaveAs Filename:="C:\Grupo2.xls", FileFormat:= _
xlNormal, CreateBackup:=False

'Copiamos la hoja del Grupo 1

Workbooks(1).Worksheets(3).Copy After:=Workbooks(2).Worksheets(1)

Set Nombre = Worksheets(2)

Nombre.Name = "Grupo 2"

Application.DisplayAlerts = False

Worksheets("Hoja1").Delete

Application.DisplayAlerts = True

'Vamos cerrando

Cells(1, 1).Select

ActiveWindow.ScrollRow = Cells(1, "A").Row

ActiveWindow.ScrollColumn = Cells(1, "A").Column

Application.DisplayAlerts = False

Workbooks("Grupo2.xls").Close Savechanges:=True

Application.DisplayAlerts = True

'Creamos un libro nuevo GRUPO 3

'Elegimos una sola hoja

Application.SheetsInNewWorkbook = 1

'Creamos el libro

Set wrkNuevo = Workbooks.Add

ActiveWorkbook.SaveAs Filename:="C:\Grupo3.xls", FileFormat:= _
xlNormal, CreateBackup:=False

'Copiamos la hoja del Grupo 1

Workbooks(1).Worksheets(4).Copy After:=Workbooks(2).Worksheets(1)

Set Nombre = Worksheets(2)

Nombre.Name = "Grupo 3"

Application.DisplayAlerts = False

Worksheets("Hoja1").Delete

Application.DisplayAlerts = True

'Vamos cerrando

Cells(1, 1).Select

ActiveWindow.ScrollRow = Cells(1, "A").Row

ActiveWindow.ScrollColumn = Cells(1, "A").Column

Application.DisplayAlerts = False

Workbooks("Grupo3.xls").Close Savechanges:=True

Application.DisplayAlerts = True

'Envío automático de emails

email "Gasto de materiales. Grupo1.", "correo1@vbatotal.com", "C:\Grupo1.xls"

email "Gasto de materiales. Grupo2.", Array("correo1@vbatotal.com", "correo2@vbatotal.com"), "C:\Grupo2.xls"

email "Gasto de materiales. Grupo3.", Array("correo1@vbatotal.com", "correo3@vbatotal.com"), "C:\Grupo3.xls"

'Activamos el refresco de pantalla

Application.ScreenUpdating = True

End Sub

Macro 5. Función para el envío de correos automáticos (Lotus).

Sub email(Subject, Recipient, Attachment)

'Función para el envío automático de correos

Dim Maildb As Object

Dim mailDoc As Object

Dim body As Object

Dim session As Object

'Iniciamos la sesión en Lotus

Set session = CreateObject("Notes.NotesSession")

'Abrimos la base de datos de Lotus

Set Maildb = session.GetDatabase("", "names.nsf")

If Not Maildb.IsOpen = True Then

Call Maildb.Open

End If

'Creamos un nuevo correo

Set mailDoc = Maildb.CreateDocument

Call mailDoc.ReplaceItemValue("Form", "Memo")

'Los destinatarios del correo están definidos en la llamada de la función

Call mailDoc.ReplaceItemValue("SendTo", Recipient)

'El asunto del correo está definido en la llamada de la función

Call mailDoc.ReplaceItemValue("Subject", Subject)

'Contenido del correo

Set body = mailDoc.CreateRichTextItem("Body")

Call body.AppendText("Buenos días,")

Call body.AddNewLine(2)

Call body.AppendText("Adjunto archivo con los gastos de materiales.")

Call body.AddNewLine(2)

Call body.AppendText("Saludos.")

'Adjuntos del correo

Call body.AddNewLine(4)

Call body.EmbedObject(1454, "", Attachment)

Call body.AddNewLine(2)

'Pie del correo

Call body.AddNewLine(2)

Call body.AppendText("Este es un correo automático.")

'Envío del correo

Call mailDoc.ReplaceItemValue("PostedDate", Now())

Call mailDoc.send(False)

'Limpiamos

Set Maildb = Nothing

Set mailDoc = Nothing

Set body = Nothing

Set session = Nothing

End Sub

Macro 6. Filtrar el informe del Grupo 1 por última fecha e imprimir automáticamente los registros de la hoja Excel en VBA.

Sub imprimir()

Sheets("Grupo 1").Select

'Ordenamos los registros por fecha de más antiguo a más reciente

ActiveWorkbook.Worksheets("Grupo 1").AutoFilter.Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Grupo 1").AutoFilter.Sort.SortFields.Add Key:= _
Range("H1:H101"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal

With ActiveWorkbook.Worksheets("Grupo 1").AutoFilter.Sort

        .Header = xlYes

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

End With

'Buscamos la fila con el último registro

f = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row

'Filtramos por fecha del último registro, dando la vuelta a la fecha y pasando a formato americano

Dim fecha As String

fecha = Format(Cells(f, "H"), "mm/dd/yyyy")

ActiveSheet.Range("$A$1:$K$101").AutoFilter Field:=8, Operator:= _
xlFilterValues, Criteria2:=Array(2, fecha)

'Imprimimos

Range(Cells(1, "A"), Cells(f, "K")).PrintOut

End Sub

Vamos a analizar la macro 6, que se encargará de imprimir la selección de registros de la hoja Excel usando únicamente VBA.

En primer lugar, comenzamos seleccionando la hoja del Grupo 1,

Sub imprimir()

Sheets("Grupo 1").Select

Ya que, lo que queremos saber es la última fecha de todos los registros del informe, no tenemos más que ordenarlos en orden ascendente y ver la fecha del último registro.

También, podíamos haber utilizado la función Advancedfilter Unique para saber cuántas fechas distintas hay y elegir la mayor, pero eso ya os lo dejo como ejercicio.

Antes de ordenar, nos aseguramos de que en la hoja no hay más filtros insertados.

'Ordenamos los registros por fecha de más antiguo a más reciente

ActiveWorkbook.Worksheets("Grupo 1").AutoFilter.Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Grupo 1").AutoFilter.Sort.SortFields.Add Key:= _
Range("H1:H101"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal

With ActiveWorkbook.Worksheets("Grupo 1").AutoFilter.Sort

        .Header = xlYes

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

End With

A continuación, buscamos la fila con el último registro.

'Buscamos la fila con el último registro

f = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row

total-operaciones-matematicas-macros

Seguidamente, filtramos la hoja por la fecha del último registro, en nuestro ejemplo el día 23/07/2018. Ya que, el comando trabaja con la fecha americana, tenemos que hacer previamente la conversión a dicho formato mm/dd/aaaa.

'Filtramos por fecha del último registro, dando la vuelta a la fecha y pasando a formato americano

Dim fecha As String

fecha = Format(Cells(f, "H"), "mm/dd/yyyy")

ActiveSheet.Range("$A$1:$K$101").AutoFilter Field:=8, Operator:= _
xlFilterValues, Criteria2:=Array(2, fecha)

total-operaciones-matematicas-macros

Por último, realizamos la selección del rango a imprimir, y lo lanzamos a la impresora.

'Imprimimos

Range(Cells(1, "A"), Cells(f, "K")).PrintOut

End Sub

Por el contrario, si lo que queremos es imprimir la hoja completa, sustituiríamos este último comando por

ActiveSheet.PrintOut

Con esto llegamos al final de la vigésimo novena lección, en la que has aprendido a imprimir una selección de registros de una hoja Excel usando VBA.

También, hemos llegado al final del curso. Espero que os haya sido de gran utilidad y esta herramienta que habéis aprendido a utilizar os ayude a quitaros tanto trabajo como a mí.

Ya sabéis que podéis consultarme cualquier duda que tengáis, será un placer para mí echaros una mano en lo que pueda.

Un saludo.

Descarga el archivo del ejemplo

« EP8. Cómo enviar un informe por email con macros.

Blog. »

0 comentarios

Enviar un comentario

Tu dirección de correo electrónico no será publicada. Los campos obligatorios están marcados con *

Este sitio usa Akismet para reducir el spam. Aprende cómo se procesan los datos de tus comentarios.

Quizá te interese,

Contacto