Adjuntar varios archivos y enviar a varios correos en Excel
Dante amor, tengo esta macro y deseo adjuntar archivos cuya dirección se encuentran en la columna "Q", para cada email se adjuntará diferentes archivos pdf.
--------------------------------------------------------
Private Sub Workbook_Open()
'Por.Dante Amor
Set h = Sheets("control")
For i = 7 To h.Range("H" & Rows.Count).End(xlUp).Row
If IsDate(h.Cells(i, "H")) And h.Cells(i, "I") = "" And h.Cells(i, "CA") = "" Then
dia = WorksheetFunction.WorkDay(h.Cells(i, "H"), -5)
If Date >= dia Then
'enviar correo
h.Cells(i, "CA") = "x"
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = h.Cells(i, "N") & ";" & h.Cells(i, "O") & ";" & h.Cells(i, "P") 'Destinatarios
dam.Subject = "RESPUESTA A DOCUMENTO POR VENCER " & _
h.Cells(i, "F") & "-" & h.Cells(i, "E") '"Asunto"
dam.Body = "Estimado " + vbNewLine & _
h.Cells(i, "A") + vbCrLf + vbCrLf & _
"Es para hacerle recordar que para dar respuesta al documento " & _
h.Cells(i, "F") & " - " & h.Cells(i, "E") & " - " & h.Cells(i, "D") & ", " & _
" tiene plazo hasta el " & _
h.Cells(i, "H") & ". " + vbNewLine & _
"Atentamente " + vbNewLine & _
"La Jefatura "
dam.Send
End If
End If
Next
End Sub
Puedes descargar de google drive mi archivo con algunas otras opciones:
Gracias Dante amor por tu tiempo, casualmente estoy utilizando esta macro y funciona perfectamente al enviar correo a todos de la lista
Pero si solo quiero enviar correo al 1° al 3° y 5° aparece el siguiente error -2147467259 (80004005). Gracias de antemano por tu ayuda.
No entiendo a qué te refieres con "correo al 1° al 3° y 5° "
Puedes poner aquí el código que utilizas.
Qué dice el mensaje de error y en cuál línea se detiene la macro.
También puedes poner una imagen aquí de una muestra de tus datos. Si es información confidencial, cambia por datos genéricos.
1 respuesta más de otro experto
Yo uso la siguiente macro
Sub correo_1()
Dim mi_App As Object
Dim mi_Correo As Object
i = 1
Do
i = i + 1
Set mi_App = CreateObject("Outlook.Application")
mi_App.Session.logon
Set mi_Correo = mi_App.CreateItem(0)
ActiveWorkbook.Save
On Error Resume Next
With mi_Correo
.SentOnBehalfOfName = "[email protected]"
.To = Range("B" & i).Value
.CC = Range("C" & i).Value
.BCC = Range("D" & i).Value
.Subject = Range("E" & i).Value
.Body = Range("F" & i).Value
.Attachments.Add Range("G" & i).Value
.Attachments.Add Range("H" & i).Value
.DeleteAfterSubmit = False
.Send
End With
'MsgBox "Email enviado con éxito"
On Error GoTo 0
Set mi_Correo = Nothing
Set mi_App = Nothing
Loop Until i = 3
End Sub