Como enviar correos masivos con excel y con adjunto diferente
Para Dante Amor
Buen día, Tu código funciona a la perfección, pero tengo la ultima pregunta no se si quizás me puedas ayuda, es que tengo esto
(Es un ejemplo)
Quisiera saber si existe un código que funcione para enviar esos correos electrónicos. Ejemplo
El la celda que se muestra siempre estarán los correos a los cuales se les enviara
Y siguiente se pondrán las cedulas de las personas las cuales serán los adjuntos, que se podrían buscar con el código que tu me regalaste.
Tengo los dos códigos un código que es para enviar correos y el otro código que es el que tu me regalaste, aun no logro juntar los dos, no se si tu tengas una forma más sencilla de hacer ese proceso.
Te lo agradecería mucho.
Codigo para enviar Correos
La diferencia es que aqui tengo los pdf's en forma vertical y no horizontal
Imagen:
Aqui la diferencia es que se adjuntan los pdfs que estan a lo largo osea Ejemplo(B2, C2, D2, E2, F2) para el primer mensaje luego al pasar al otro mensaje se adjuntar igual pero con ejemplo (B3, C3, D3, E3, F3)
Cosa que quiero evitar y que se adjunten asi (B2, B3, B4, B5, B6, B7... BN) Y asi para todos los mensajes que se quieran enviar.
Dim AppSaliente, CorreoSaliente As Object
Dim HojaCalculo As Worksheet
Dim celda, CeldArchivo, rango As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set HojaCalculo = Sheets("Correo")
Set AppSaliente = CreateObject("Outlook.Application")
For Each celda In HojaCalculo.Columns("B").Cells.SpecialCells(xlCellTypeVisible)
'Poner los nombres en las columnas C:Z de cada fila
Set rango = HojaCalculo.Cells(celda.Row, 1).Range("C1:bZ1")
If celda.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rango) > 0 Then
Set CorreoSaliente = AppSaliente.CreateItem(0)
With CorreoSaliente
.To = celda.Value
.Subject = Worksheets("Envio De mensajes").Range("A2").Value
.Body = Worksheets("Envio De mensajes").Range("A6").Value
'.Attachments.Add ActiveWorkbook.FullName
For Each CeldArchivo In rango.SpecialCells(xlCellTypeVisible)
If Trim(CeldArchivo) <> "" Then
If Dir(CeldArchivo.Value) <> "" Then
.Attachments.Add CeldArchivo.Value
Else
If CeldArchivo.Value = "" Then
Else
cad = cad & CeldArchivo.Value & " "
End If
End If
Else
End If
Next CeldArchivo
'Display
.Send 'para enviar sin comprobar
End With
Set CorreoSaliente = Nothing
End If
Next celda
Set AppSaliente = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
respuesta = MsgBox("Pdf no encontrado" & cad)
De esta manera están los datos, y como se puede observar de la celda b2 hacia abajo se encontrarían todos los correos a los cuales se le enviara (Ojo esto no es una copia lo que hace es un correo aparte para todos)
Y como se puede observar todos los adjuntos están ordenados por filas más no por columnas ejemplo:(B2, C2, D2, E2, F2) para el primer mensaje luego al pasar al otro mensaje se adjuntar igual pero con ejemplo (B3, C3, D3, E3, F3)
No pusiste cómo van a estar tus datos, pusiste cómo los tienes, pero entiendo que los vas a acomodar de otra forma.
La macro está incompleta, faltaron algunas líneas.
Mejor envíame tu archivo para revisar cómo vas a tener tus datos. Y de paso también reviso el msgbox de los archivos que no se encuentran.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Alexander Rodriguez Villamizar” y el título de esta pregunta.
Dante, ya envíe el archivo quedo muy agradecido cualquier ayuda que me puedas brindar
Te anexo la macro para juntar las macros
Private Sub UserForm_Activate()
'Por.Dante Amor
Set h1 = Sheets("Envio De mensajes")
Set h2 = Sheets("temp")
h2.Cells.Clear
'
Label3.Caption = "ENVIANDO CORREOS"
ruta = h1.Range("A4")
If ruta = "" Then MsgBox "Ingresa la carpeta": Exit Sub
If Dir(ruta, vbDirectory) = "" Then MsgBox "No existe la carpeta": Exit Sub
If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
'
i = 2
arch = Dir(ruta & "*.pdf")
Do While arch <> ""
h2.Cells(i, "A") = arch
i = i + 1
arch = Dir()
Loop
'
For j = Columns("D").Column To h1.Cells(2, Columns.Count).End(xlToLeft).Column
correo = h1.Cells(2, j)
Set dam = CreateObject("Outlook.Application").CreateItem(0)
dam.To = correo 'Destinatarios
dam.Subject = h1.Range("A2").Value '"Asunto"
dam.Body = h1.Range("A6").Value '"Cuerpo del mensaje"
'
For i = 3 To h1.Cells(Rows.Count, j).End(xlUp).Row
cedula = h1.Cells(i, j)
Set b = h2.Columns("A").Find(cedula, lookat:=xlPart)
If Not b Is Nothing Then
dam.Attachments.Add ruta & b.Value
Else
ListBox1.AddItem correo
ListBox1.List(ListBox1.ListCount - 1, 1) = cedula
End If
Next
Dam. Send 'El correo se envía en automático
'dam. Display 'El correo se muestra
Next
Label3.Caption = "ARCHIVOS QUE NO FUERON ENVIADOS"
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
