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
2 Respuestas
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.
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