Ejercicio práctico 9: Cómo imprimir informes automáticamente mediante macros.

Escrito por Administrador

26 de agosto de 2021

Vamos a terminar el curso de programación en Visual Basic para Excel, complementando el último ejercicio práctico.

Además de elaborar y enviar los informes por correo, haremos una selección de datos y los imprimiremos también de manera automática. Así podremos programar cualquier casuística de empresa.

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

Una vez se envíen los correos, se filtrará la tabla del Grupo 1 por la última fecha que contenga, y se enviarán dichos registros directamente a la impresora.

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

A continuación, adjunto el código. Las cinco primeras macros son exactamente las mismas que las del ejercicio práctico anterior.

Macro 1. Generación de 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. Borrado de 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. Ordenación de 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. Creación automática de archivos y llamada a 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. Filtrado del informe del Grupo 1 por última fecha e impresión automática de registros.

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.

Comenzamos seleccionando la hoja del Grupo 1,

Sub imprimir()

Sheets("Grupo 1").Select

Como lo que queremos es saber cuál 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

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

A continuación, filtramos la hoja por la fecha del último registro, en nuestro ejemplo el día 23/07/2018. Como 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)

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

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 y, por tanto, del curso. Espero que os haya sigo 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.

Nos vemos en próximos cursos. 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