Macro para enviar correos automáticamente desde el Excel con archivo adjunto
Para Dante Amor
Hola Dante! Buen día
¿Me podrías apoyar creando una macro en donde de un archivo de Excel se envíen automáticamente correos con un archivo adjunto?
Si gustas puedo enviarte un ejemplo por correo para poder explicarte un poco mejor
Respuesta de Dante Amor
2
Excelente!
Muchas gracias, ya te envíe el correo :)
Quedo al pendiente
Saludos!
H o l a: Te anexo la macro
Sub Enviar_Correos()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Set l1 = ThisWorkbook
Set h1 = Sheets("CONSOLIDADO COMPLETO")
Set h2 = Sheets("Hoja2")
Set h3 = Sheets("Hoja3")
h2.Cells.Clear
'
ruta = l1.Path & "\"
arch = l1.Name
If LCase(Right(arch, 5)) = ".xlsm" Then
arch = Mid(arch, 1, Len(arch) - 5)
End If
'
h1.Range("A1").AutoFilter
u = h1.Range("D" & Rows.Count).End(xlUp).Row
If h1.AutoFilterMode Then h1.AutoFilterMode = False
h1.Columns("D").Copy h2.Range("A1")
h2.Range("A1:A" & u).RemoveDuplicates Columns:=1, Header:=xlYes
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To u2
lider = h1.Cells(i, "D")
concopia = ""
h1.Range("A1:J" & u).AutoFilter Field:=4, Criteria1:=lider
u1 = h1.Range("D" & Rows.Count).End(xlUp).Row
h3.Cells.Clear
h1.Range("A1:J" & u1).Copy h3.Range("A1")
'para = h3.Range("D2")
For j = 2 To h3.Range("C" & Rows.Count).End(xlUp).Row
asesor = h3.Cells(j, "C")
If InStr(1, concopia, asesor) = 0 Then
concopia = concopia & asesor & "; "
End If
Next
'
h3.Copy
Set l2 = ActiveWorkbook
l2.SaveAs Filename:=ruta & arch & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
l2.Close False
'
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = lider
dam.CC = concopia
dam.Subject = "En Esta Parte Se Pone El Asunto"
dam.Body = "Aquí Se Pone El Cuerpo Del Mensaje"
dam.Attachments.Add ruta & arch & ".xlsx"
'dam.Send 'El correo se envía en automático
dam.Display 'El correo se muestra
Next
MsgBox "Proceso terminado", vbInformation, "ENVIAR CORREOS :)"
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Hola Dante!
Excelente! Muchísimas gracias!
Una duda más, si los datos de la columna D no siempre son los mismos como puedo hacer para que tome en cuenta a todos?
Y sobre los correos, que puedo hacer para que solo se abra una vez el correo y no varias veces con los mismos destinatarios?
Gracias! Quedo al pendiente
Te anexo la macro actualizada
Sub Enviar_Correos()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Set l1 = ThisWorkbook
Set h1 = Sheets("CONSOLIDADO COMPLETO")
Set h2 = Sheets("Hoja2")
Set h3 = Sheets("Hoja3")
h2.Cells.Clear
'
ruta = l1.Path & "\"
arch = l1.Name
If LCase(Right(arch, 5)) = ".xlsm" Then
arch = Mid(arch, 1, Len(arch) - 5)
End If
'
h1.Range("A1").AutoFilter
u = h1.Range("D" & Rows.Count).End(xlUp).Row
If h1.AutoFilterMode Then h1.AutoFilterMode = False
h1.Columns("D").Copy h2.Range("A1")
h2.Range("A1:A" & u).RemoveDuplicates Columns:=1, Header:=xlYes
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To u2
lider = h2.Cells(i, "A")
concopia = ""
h1.Range("A1:J" & u).AutoFilter Field:=4, Criteria1:=lider
u1 = h1.Range("D" & Rows.Count).End(xlUp).Row
h3.Cells.Clear
h1.Range("A1:J" & u1).Copy h3.Range("A1")
'para = h3.Range("D2")
For j = 2 To h3.Range("C" & Rows.Count).End(xlUp).Row
asesor = h3.Cells(j, "C")
If InStr(1, concopia, asesor) = 0 Then
concopia = concopia & asesor & "; "
End If
Next
'
h3.Copy
Set l2 = ActiveWorkbook
l2.SaveAs Filename:=ruta & arch & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
l2.Close False
'
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = lider
dam.CC = concopia
dam.Subject = "En Esta Parte Se Pone El Asunto"
dam.Body = "Aquí Se Pone El Cuerpo Del Mensaje"
dam.Attachments.Add ruta & arch & ".xlsx"
'dam.Send 'El correo se envía en automático
dam.Display 'El correo se muestra
Next
MsgBox "Proceso terminado", vbInformation, "ENVIAR CORREOS :)"
End Subsal u dos
