Macro para enviar correos con adjuntos de manera masiva

H o l a:

Tengo una aplicación que sirve para enviar correos masivos, a diferentes destinatarios, con diferentes asuntos, diferentes cuerpos de correo, con diferentes archivos y puedes seleccionar el correo de salida.

Las macros son estas:

El formato del archivo es este, en la columna G se pone el número de correo.

Segundo, las cuentas de correo están numeradas del 1 en adelante:

Entonces, considera ese número como el identificador de la cuenta. En la columna G vas a poner ese número según la cuenta de salida.

Sigue las Instrucciones para ver las macros en los eventos de worksheet

1. Abre tu libro de excel
2. Para abrir Vba-macros y poder ver la macro, Presiona Alt + F11
3. Del lado izquierdo dice: VBAProject, abajo dale doble click a worksheet(Hoja1)
4. En el panel del lado derecho pon las macros.

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
    On Error Resume Next
    If Not Intersect(Target, Range("B:B")) Is Nothing Then
        For Each t In Target
            If t.Value <> "" Then
                Cells(t.Row, "H").Select
                ActiveSheet.Hyperlinks.Add _
                    Anchor:=Selection, _
                    Address:="", _
                    SubAddress:="Hoja1!C" & t.Row, _
                    TextToDisplay:="Insertar archivo"
            End If
        Next
        Cells(Target.Row, 3).Select
    End If
End Sub
'
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'Por.Dante Amor
    linea = ActiveCell.Row
    col = Range("I1").Column
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Seleccione uno o varios archivos"
        .Filters.Clear
        .Filters.Add "archivos pdf", "*.pdf*"
        .Filters.Add "archivos de excel", "*.xls*"
        .Filters.Add "Todos los archivos", "*.*"
        .FilterIndex = 2
        .AllowMultiSelect = True
        .InitialFileName = ThisWorkbook.Path
        If .Show Then
            For Each ar In .SelectedItems
                'rutaarchivo = .SelectedItems.Item(i)
                Cells(linea, col) = ar
                col = col + 1
            Next
        End If
    End With
End Sub

Sigue las Instrucciones para copiar la macro en el módulo

1. Abre tu archivo de excel
2. Para abrir Vba-macros y ver la macro, Presiona Alt + F11
3. Del lado izquierdo dice: VBAProject, abajo dale doble click a Módulo1
4. En el panel del lado derecho pega la macro:

'***Macro Para enviar correos
Sub correo()
'Por.Dante Amor
    col = Range("I1").Column
    For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
        Set dam = CreateObject("outlook.application").createitem(0)
        dam.To = Range("B" & i) 'Destinatarios
        dam.CC = Range("C" & i) 'Con copia
        dam.Bcc = Range("D" & i) 'Con copia oculta
        dam.Subject = Range("E" & i) '"Asunto"
        dam.body = Range("F" & i) '"Cuerpo del mensaje"
        If Range("G" & i) = "" Or Not IsNumeric(Range("G" & i)) Then
            n = Range("G" & i)
        Else
            n = Range("G" & i)
        End If
        dam.SendUsingAccount = dam.Session.Accounts.Item(n) '
        '
        For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
            archivo = Cells(i, j)
            If archivo <> "" Then dam.Attachments.Add archivo
        Next
        dam.send 'El correo se envía en automático
        'dam.display 'El correo se muestra
    Next
    MsgBox "Correos enviados", vbInformation, "SALUDOS"
End Sub

Envíame un correo para que te envíe la aplicación y la revises.

Mi correo [email protected]

En el asunto del correo escribe tu nombre de usuario “” y el título de esta pregunta.

Avísame en esta pregunta cuando me lo hayas enviado.

':)
':)

Hola Dante, ya te envíe el correo, muchas gracias por tu ayuda.

Te envié la aplicación, en la hoja va un ejemplo.

Puedes poner más correos hacia abajo. Puedes agregar más destinatarios separados por punto y como ( ; )

':)
':)

Dante te mande un correo, me sale error.