Macro para enviar correos automáticamente desde el Excel con archivo adjunto

H o l a: Envíame un correo y me explicas con detalle lo que necesitas. ¿El correo se va a enviar por outlook?

R ecuerda poner tu nombre de usuario en el asunto.

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