Copiar tabla de un excel en el cuerpo de un correo de Outlook
Antes que nada comentaros que os leo mucho y ahora me he animado a participar y poder ayudar en todo lo posible.
Primeramente os quiero plantear un problemilla que tengo y es que quiero generar a traves de Excel un correo.
Consigo generar el correo, escribir un texto pero me falta adjuntar en el cuerpo del mensaje una tabla que tengo en el excel. Esa tabla va variando de filas y serán varias.
El mensaje lo escribo en código html.
Hasta ahora lo que tengo es lo siguiente:
Sub enviar_correo()
Application.ScreenUpdating = False
Application.Wait (Now + TimeValue("00:00:01"))
Dim tabla_alta_sello As String
Dim OutApp As Object
Dim Outmail As Object
Set AppOutlook = Nothing
On Error Resume Next
Do While True
Set AppOutlook = CreateObject("outlook.application")
If Not AppOutlook Is Nothing Then
Exit Do
End If
Loop
On Error GoTo 0
Application.Wait (Now + TimeValue("00:00:01"))
Set OutApp = CreateObject("Outlook.Application")
Application.Wait (Now + TimeValue("00:00:01"))
Set Outmail = OutApp.createitem(0)
Dim MensajeHTML As Variant
Dim Tabla As Variant
With Outmail
Sheets("Preparar correo").Select
Range("A2:D3").Select
'Set tabla_alta_sello = Range("A2:D3")
MensajeHTML = "<span style='font: 13px verdana;'>" & _
" Buenos días," & _
"
Se ha producido una nueva actualización de la lista de sellos a la que podéis acceder en el servidor FTP" & _
"
Los cambios producidos han sido:" & _
'AQUÍ DEBERIAN DE IR LAS TABLAS
"
Gracias y saludos." & _
"</span>"
.display
.To = ""
.cc = ""
.Bcc = ""
.Subject = Format(Now(), "yymmdd") & " Listado de sellos actualizado"
.HTMLBody = MensajeHTML & .HTMLBody & strbody
End With
On Error GoTo 0
Set Outmail = Nothing
Set OutApp = Nothing
Sheets("Actualizaciones").Select
End Sub
En esta respuesta he armado una tabla en html
¿Cómo envío correo automático confirmando solicitud por formulario Excel, prog en Visual Basic?
En esta línea de la macro establezco el rango de la tabla:
Set r = hoja.Range("A" & fila & ":U" & fila)Puedes cambiar el rango por el nombre de la tabla, por ejemplo:
Sub EnviarCorreo()
'Por.Dante Amor
Set hoja = ActiveSheet
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = ""
dam.Subject = ""
'
cuerpo = "Correo automático"
Set r = hoja.Range("Tabla1")
fini = r.Cells(1, 1).Row
ffin = fini + r.Rows.Count - 1
cini = r.Cells(1, 1).Column
cfin = cini + r.Columns.Count - 1
tabla = "<table border><tr>"
For i = fini To ffin
For j = cini To cfin
tabla = tabla & "<td>" & hoja.Cells(i, j) & "</td>"
Next
tabla = tabla & "</tr>"
Next
tabla = tabla & "</table>"
dam.HTMLBody = _
"<HTML> " & _
"<BODY>" & _
"<P>" & cuerpo & tabla & "</P>" & _
"</BODY> " & _
"</HTML>"
'dam. Send 'El correo se envía en automático
dam.Display 'El correo se muestra
End SubSi la tabla tiene encabezado en esta línea resta menos 1
fini = r.Cells(1, 1).Row - 1
Sigue el mismo código para crear la tabla2, tabla3, etc
Set r = hoja.Range("Tabla1")
fini = r.Cells(1, 1).Row
ffin = fini + r.Rows.Count - 1
cini = r.Cells(1, 1).Column
cfin = cini + r.Columns.Count - 1
tabla = "<table border><tr>"
For i = fini To ffin
For j = cini To cfin
tabla = tabla & "<td>" & hoja.Cells(i, j) & "</td>"
Next
tabla = tabla & "</tr>"
Next
tabla = tabla & "</table>"
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
¡Gracias!
Mañaana lo probaré en el trabajo,
Muchas gracias, te responderé.
Saludos!
Buenas,
Antes que nada te agradezco tu ayuda.
Comentarte que me da error en la siguiente línea:
tabla = tabla & "<td>" & hoja.Cells(i, j) & "</td>"
Mi código tiene la siguiente forma:
Sub enviar_correo()
Set hoja = Sheets("Preparar correo")
Application.ScreenUpdating = False
Application.Wait (Now + TimeValue("00:00:01"))
Dim tabla_alta_sello As String
Dim OutApp As Object
Dim Outmail As Object
Dim tabla As Range
Set AppOutlook = Nothing
On Error Resume Next
Do While True
Set AppOutlook = CreateObject("outlook.application").createitem(0)
If Not AppOutlook Is Nothing Then
Exit Do
End If
Loop
On Error GoTo 0
Application.Wait (Now + TimeValue("00:00:01"))
Set OutApp = CreateObject("Outlook.Application")
Application.Wait (Now + TimeValue("00:00:01"))
Set Outmail = OutApp.createitem(0)
Dim MensajeHTML As Variant
With Outmail
Set r = hoja.Range("Tabla10")
fini = r.Cells(1, 1).Row - 1
ffin = fini + r.Rows.Count - 1
cini = r.Cells(1, 1).Column
cfin = cini + r.Columns.Count - 1
tabla = "<table border><tr>"
For i = fini To ffin
For j = cini To cfin
tabla = tabla & "<td>" & hoja.Cells(i, j) & "</td>"
Next
tabla = tabla & "</tr>"
Next
tabla = tabla & "</table>"
MensajeHTML = "<span style='font: 13px verdana;'>" & _
" Buenos días," & _
"
Se ha producido una nueva actualización de la lista de sellos a la que podéis acceder en el servidor FTP de MAVE en la siguiente ruta: " & _
"
/SISTEMAS-CALIDAD/SG Calidad/PC-751 Control, identificación y trazabilidad/Registros" & _
"
Los cambios producidos han sido:" & _
"<P>" & tabla & "</P>" & _
"
Gracias y saludos." & _
"</span>"
.display
.To = ""
.cc = ""
.Bcc = ""
.Subject = Format(Now(), "yymmdd") & " Listado de sellos actualizado"
.HTMLBody = MensajeHTML & .HTMLBody & strbody
End With
On Error GoTo 0
Set Outmail = Nothing
Set OutApp = Nothing
Sheets("Actualizaciones").Select
End Sub
Perdón, la línea donde me da error es la siguiente:
tabla = "<table border><tr>"
Gracias
La variable tabla no es un rango, es un string
La declaraste así:
Dim tabla As Range
Debe ser así:
Dim tabla As String
En VBA no es necesario declarar variables. La macro funcionaría si no hubieras declarado las variables.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Gracias!!!
Y por último, sabrías como podría poner la tabla con el siguiente formato?
Ahora aparece uno muy básico.
Muchas gracias
Tienes que modificar los colores y los estilos en HTML
Con mucho gusto te ayudo con todas tus peticiones.
Valora esta respuesta y crea una nueva pregunta en el tema de microsoft Excel. En el desarrollo de la pregunta escribe: "para Dante Amor". Ahí me describes con detalle lo que necesitas.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
