Un solo email con varios archivos adjuntos según listado en una hoja
Tengo una hoja que la genera automáticamente generar el fichero PDF de cada hoja por departamento y empleado, en la columna B inserta dirección de email a enviar, en la columna C insertar el nombre del DPTO, en la columna D inserta nombre del trabajador, en la columna E inserta la ruta + nombre fichero PDF, mi intención sería agrupar los fichero adjuntos por departamento y por dirección de email columna B, en un solo email, para así no tener que mandar varios email y ficheros por cada trabajador y dpto.
1 respuesta
Respuesta de Dante Amor
1
H o la :
Te anexo la macro.
Sub EnviaCorreo()
'Por.Dante Amor
Set h = Sheets("EMAIL")
ini = 2 'fila inicial con datos
ant = h.Cells(ini, "B") & h.Cells(ini, "C")
Set dam = CreateObject("outlook.application").createitem(0)
existe = False
j = ini
'
For i = ini To h.Range("B" & Rows.Count).End(xlUp).Row + 1
para = h.Cells(i, "B").Value
dpto = h.Cells(i, "C").Value
empl = h.Cells(i, "D").Value
arch = h.Cells(i, "E").Value
copi = Sheets("CONFIGEMAIL").Range("C4").Value 'Con copia
'
If ant = h.Cells(i, "B") & h.Cells(i, "C") Then
If h.Cells(i, "A") = "" Or h.Cells(i, "A") <> "Enviado" Then
With dam
.To = para 'Destinatarios
.Cc = copi
.Subject = "DETALLE HORAS MES DE" & Chr(32) & mesemail & Chr(32) & dpto & Chr(32) & empl '"Asunto"
If arch <> "" Then
If Dir(arch) <> "" Then
.Attachments.Add arch
Else
h.Cells(i, "A") = "Archivo no existe"
End If
End If
End With
existe = True
End If
Else
If existe Then
existe = False
On Error Resume Next
dam.Display
'dam.Send
If Err.Number = 0 Then
wmsg = "Enviado"
Else
wmsg = "No enviado"
End If
For k = j To i - 1
If h.Cells(k, "A") = "" Then
h.Cells(k, "A") = wmsg
End If
Next
j = i
On Error GoTo 0
End If
Set dam = Nothing
Set dam = CreateObject("outlook.application").createitem(0)
If h.Cells(i, "A") = "" Or h.Cells(i, "A") <> "Enviado" Then
With dam
.To = para 'Destinatarios
.Cc = copi
.Subject = "DETALLE HORAS MES DE" & Chr(32) & mesemail & Chr(32) & dpto & Chr(32) & empl '"Asunto"
If arch <> "" Then
If Dir(arch) <> "" Then
.Attachments.Add arch
Else
h.Cells(i, "A") = "Archivo no existe"
End If
End If
End With
existe = True
End If
End If
ant = h.Cells(i, "B") & h.Cells(i, "C")
Next
MsgBox "Fin"
End SubActualmente tiene la instrucción
Dam. Display
Pero solamente te mostrará el correo, si quieres enviarlo en automático, entonces quita el apostrofe a la línea:
'dam. Send
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
