Envío masivo de emails desde excel personalizando el asunto
Quería saber como puedo enviar correso masivos desde un archivo excel peronalizando el asunto. Tengo varias columnas con datos y una de ellas es la dirección del email.
1 respuesta
H o l a:
Tengo una aplicación para enviar correos masivos. Revisa lo siguiente y dime si hay algo que adaptar.
Envíame un correo para enviarte el archivo.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Yolanda López” y el título de esta pregunta.
Avísame en esta pregunta cuando me lo hayas enviado.
':)
S a l u d o s . D a n t e A m o r
Esta son las macros:
Pon esta macro en un módulo:
'***Macro Para enviar correos con adjunto diferente y firma
Sub correo()
'Por.Dante Amor
col = Range("H1").Column
ruta = ThisWorkbook.Path & "\"
For i = 3 To Range("B" & Rows.Count).End(xlUp).Row
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = Range("B" & i) 'Destinatarios
dam.CC = Range("C" & i) 'Con copia
dam.Bcc = Range("D" & i) 'Con copia oculta
dam.Subject = Range("E" & i) '"Asunto"
Cuerpo = Range("F" & i) '"Cuerpo del mensaje"
'
For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
archivo = Cells(i, j)
If archivo <> "" Then dam.Attachments.Add archivo
Next
'
logo = [L2]
dam.Attachments.Add ruta & logo
dam.HTMLBody = _
"<HTML> " & _
"<BODY>" & _
"<P>" & Cuerpo & "</P>" & _
"<img src=cid:" & logo & " height=40 width=40>" & _
"<br>" & "<b>" & [I2] & "</b>" & _
"<br>" & [J2] & _
"<br>" & [K2] & _
"</BODY> " & _
"</HTML>"
'dam.Display 'El correo se muestra
dam.send 'El correo se envía en automático
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End SubPon esta macro en los eventos de la hoja:
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
On Error Resume Next
If Target.Count > 1 Then Exit Sub
If Target.Row < 3 Then Exit Sub
If Not Intersect(Target, Range("B:B")) Is Nothing Then
For Each t In Target
If t.Value <> "" Then
Cells(t.Row, "G").Select
ActiveSheet.Hyperlinks.Add _
Anchor:=Selection, _
Address:="", _
SubAddress:="Hoja1!C" & t.Row, _
TextToDisplay:="Insertar archivo"
End If
Next
Cells(Target.Row, 3).Select
End If
End Sub
'
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'Por.Dante Amor
linea = ActiveCell.Row
'col = Range("H1").Column
col = Cells(linea, Columns.Count).End(xlToLeft).Column + 1
If col < 8 Then col = 8
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione uno o varios archivos"
.Filters.Clear
.Filters.Add "archivos pdf", "*.pdf*"
.Filters.Add "archivos de excel", "*.xls*"
.Filters.Add "Todos los archivos", "*.*"
.FilterIndex = 2
.AllowMultiSelect = True
.InitialFileName = ThisWorkbook.Path & "\"
If .Show Then
For Each ar In .SelectedItems
'rutaarchivo = .SelectedItems.Item(i)
Cells(linea, col) = ar
col = col + 1
Next
End If
End With
End SubLos datos los tienes que poner de esta forma:
':) ':)
¡Gracias! Mañana lo probaré
Avísame cualquier duda.
No olvides regresar a valorar la respuesta.
