Ejercicio práctico 8: Cómo enviar automáticamente informes por email (Lotus) usando una macro en Excel.

email-excel-macro

Escrito por Administrador

26 de agosto de 2021

Hoy vamos a aprender cómo enviar automáticamente un informe Excel por email usando una macro.

Para ello, vamos a darle una vuelta de tuerca al ejercicio práctico 5, donde veíamos cómo filtrar los registros de una tabla, repartiéndolos en varias hojas mediante macros. En él, repartíamos los registros de un listado en distintas hojas, en función de uno o más criterios.

total-operaciones-matematicas-macros

Y, ¿cuál sería el siguiente paso? Claro está, que una vez tenemos la información clasificada, lo interesante es hacérsela llegar a cada responsable para que actué en consecuencia, y qué mejor manera que hacerlo desde Excel a través de un email usando una macro.

Por lo tanto, la idea es que, al pulsar un nuevo botón, se envíen tres correos electrónicos a tres grupos de destinatarios diferentes, uno por cada hoja clasificada. De hecho, cada correo contendrá la información de un solo grupo, por lo que será necesario que se generen automáticamente dichos archivos individuales previo al envío.

total-operaciones-matematicas-macros

A continuación, os dejo el código para enviar automáticamente un informe de Excel por email usando una macro:

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

En primer lugar, deciros que la macro 1, que elabora el informe, es exactamente la misma que usamos en el ejercicio práctico 5, solo que he cambiado la penúltima instrucción:

Sheets("Grupo 1").Select

Por,

Sheets("Informe").Select

Para que, al finalizar, aterricemos en la hoja “Informe” y podamos seguir pulsando botones.

También, las macros 2 y 3 son las mismas que usamos en el ejercicio práctico 5.

Por el contrario, las novedades son las macros 4 y 5, que aportan la creación automática de los archivos y el envío de correos.

Macro 4. Crear automáticamente archivos y llamar 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 un email (Lotus) desde Excel usando una macro.

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

Empecemos primero analizando la macro 4.

Como siempre, en primer lugar, desactivamos el refresco de pantalla y dimensionamos las nuevas variables para el libro nuevo que vamos a crear.

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

A continuación, seleccionamos el número de hojas que queremos que tenga nuestro nuevo libro,

Dim hojasActual As Long

'Creamos un libro nuevo GRUPO 1

'Elegimos una sola hoja

Application.SheetsInNewWorkbook = 1

Después, creamos el nuevo libro,

'Creamos el libro

Set wrkNuevo = Workbooks.Add

y lo guardamos con el nombre “Grupo1.xls”

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

A continuación, copiamos la hoja 2 (Grupo 1) del libro 1 (Ejercicio practico 8.xlsx) detrás de la hoja 1 del nuevo libro,

'Copiamos la hoja del Grupo 1

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

le damos el nombre “Grupo 1”,

Set Nombre = Worksheets(2)

Nombre.Name = "Grupo 1"

y borramos la hoja que trae por defecto el libro creado. Así mismo, hemos desactivado las alertas para no tener que validar el borrado de la misma.

Application.DisplayAlerts = False

Worksheets("Hoja1").Delete

Application.DisplayAlerts = True

Enfocamos la primera celda del nuevo libro, lo guardamos y lo cerramos.

'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

Aunque no veamos nada, ahora mismo tenemos el archivo de la imagen guardado en C:\> como “Grupo1.xls”.

total-operaciones-matematicas-macros

De manera similar, realizamos las operaciones con los grupos 2 y 3.

'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

Por último, una vez creados los tres libros, tenemos que enviarlos por correo a sus respectivos destinatarios.

Para ello, he creado una función llamada “email” que se encuentra en la macro 5 y nos facilita dicha operación, pasándole como parámetros el asunto del email, la lista de destinatarios y la ruta del archivo adjunto.

De esta manera, enviamos un email desde Excel usando una macro.

total-operaciones-matematicas-macros
'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

Si miramos el cuadro de arriba, con el primer comando, por ejemplo, enviaremos un correo con el asunto “Gasto de materiales. Grupo 1” al destinatario “correo1@vbatotal.com” con el archivo adjunto ubicado en “C:\Grupo1.xls”.

Una vez dimensionamos las variables que vamos a utilizar, iniciamos sesión en 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")

y abrimos la base de datos si es que no lo está ya.

'Abrimos la base de datos de Lotus

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

If Not Maildb.IsOpen = True Then

Call Maildb.Open

End If

A continuación, creamos un nuevo correo.

'Creamos un nuevo correo

Set mailDoc = Maildb.CreateDocument

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

Los correos destinatarios han sido definidos a la hora de llamar a la función, y lo que hacemos es copiarlos en el apartado “sendTo” del nuevo correo creado.

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

Call mailDoc.ReplaceItemValue("SendTo", Recipient)

Con el asunto del correo pasa lo mismo porque ya está definido a la hora de llamar a la función y lo pasa al apartado correspondiente del nuevo correo.

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

Call mailDoc.ReplaceItemValue("Subject", Subject)

Sin embargo, el cuerpo del correo si hay que introducirlo aquí, y no es más que el mensaje que queremos transmitir. En este caso “Buenos días, adjunto archivo con los gastos de materiales. Saludos”

'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.")

El comando Call body.AddNewLine(2) hace tantos saltos de renglón como número indicamos entre paréntesis. En este caso dos.

Llegamos al apartado de adjuntos. También los definimos al llamar a la función, así que simplemente los introduce en el apartado correspondiente del nuevo correo.

'Adjuntos del correo

Call body.AddNewLine(4)

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

Call body.AddNewLine(2)

Por último, introducimos en el pie de correo la frase “Este es un correo automático.” y ya lo tenemos listo. Solo nos quedaría ejecutar la macro pulsando el botón, para enviar el email desde Excel.

'Pie del correo

Call body.AddNewLine(2)

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

total-operaciones-matematicas-macros

Una vez cumplimentados todos los campos, realizamos el envío del mismo y limpiamos por si queremos enviar otro.

'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

Con esto llegamos al final de la vigésimo octava lección, en la que has aprendido cómo enviar un informe por email de manera automática desde Microsoft Excel utilizando una macro.

Finalmente, desear que te esté gustando el curso y pedirte que me plantees cualquier duda que te surja. También puedes proponerme macros que te interese desarrollar y las voy incluyendo en el temario. De hecho, soy todo oídos. Nos vemos en el próximo capítulo.

Descarga el archivo del ejemplo

« EP7. Cómo usar Change e Intersect en macros.

EP9. Cómo imprimir informes con macros. »

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