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.
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.
'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.
'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.
'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).
'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).
'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.
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,
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.
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.
f = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row
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.
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.
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í.
Por último, quiero invitarte a compartir tus dudas en los comentarios o en el foro. Intentaré ayudarte en todo lo que pueda, y así aprenderemos todos.
Un saludo.
Si te ha servido y quieres donar
Descarga el archivo del ejemplo
« EP8. Cómo enviar un informe por email con macros.
Blog. »
0 comentarios