¿Cómo crear macro para enviar diferente información a cada destinatario?
De antemano gracias por tu tiempo para ayudarme con mi petición.
Lo que ando buscando es que la macro envíe información especifica a cada destinatario, son varias columnas de mi archivo excel que quiero que copie a un correo electrónico y se envíe al destinatario.
1 Respuesta
Respuesta de Dante Amor
2
H o l a :
Te anexo la macro
Dim tabla, inicio, instrucciones, saludos
'***Macro Para enviar correos
Sub EnviarCorreo()
'Por.Dante Amor
Application.EnableEvents = True
'
Dim numero As New Collection
Set h1 = Sheets("Base de Datos")
Set h2 = Sheets("Info Emails")
Set numero = Nothing
'
For i = 2 To h2.Range("A" & Rows.Count).End(xlUp).Row
user = h2.Cells(i, "A").Value
Set r = h1.Columns("N")
Set b = r.Find(user, lookat:=xlWhole)
If Not b Is Nothing Then
celda = b.Address
Do
numero.Add b.Row
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celda
'
correo = h2.Cells(i, "B").Value
tabla = ""
inicio = ""
instrucciones = ""
saludos = ""
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = correo
dam.Subject = "CONFIRMACION DE ORDEN DE COMPRA - INSTRUCCION PARA PAGO"
'
Call CrearTabla(h1, numero)
Call CrearMsg
'
dam.HTMLBody = _
"<HTML> " & _
"<BODY>" & _
"<P> " & inicio & _
"<br> " & tabla & _
"<br> " & instrucciones & "<br> " & _
"<br> " & saludos & _
"</P> " & _
"</BODY> " & _
"</HTML>"
dam.Display 'El correo se muestra
dam.Send 'El correo se envía en automático
Set dam = Nothing
Set numero = Nothing
End If
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End Sub
'
Sub CrearTabla(h1, numero)
'Por.Dante Amor
tabla = "<table border><tr>"
ant2 = user
cols = Array("N", "F", "A", "B", "D", "C", "E", "L", "M")
For k = LBound(cols) To UBound(cols)
tabla = tabla & "<td>" & h1.Cells(1, cols(k))
Next
tabla = tabla & "</tr>"
For j = 1 To numero.Count
For k = LBound(cols) To UBound(cols)
tabla = tabla & "<td>" & h1.Cells(numero(j), cols(k)) & "</td>"
Next
tabla = tabla & "</tr>"
Next
tabla = tabla & "</table>"
End Sub
'
Sub CrearMsg()
'Por.Dante Amor
Set hm = Sheets("Mensaje")
For k = 3 To hm.Range("A" & Rows.Count).End(xlUp).Row
Select Case LCase(hm.Cells(k, "A"))
Case "inicio"
inicio = inicio & hm.Cells(k, "B") & "<br> "
Case "instrucciones"
instrucciones = instrucciones & hm.Cells(k, "B") & "<br> "
Case "saludos"
saludos = saludos & hm.Cells(k, "B") & "<br> "
End Select
Next
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
