Combinar correspondencia con datos adjuntos

H o l a:

Tengo una aplicación para enviar correos masivos con varios archivos a diferentes destinatarios, con diferentes asuntos y diferentes cuerpos.

Pon esta macro en un módulo:

'***Macro Para enviar correos
Sub correo()
'Por.Dante Amor
    col = Range("H1").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"
        '
        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

Pon esta macro en los eventos de la hoja:

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dam
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, "G").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.Dam
    linea = ActiveCell.Row
    'col = Range("H1").Column
    col = Cells(linea, Columns.Count).End(xlToLeft).Column + 1
    If col < 8 Then col = 8
    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

Los datos los tienes que poner de esta forma:

Si quieres el archivo, envíame un correo a

[email protected]

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

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

':)
':)

Dante, ya!!! muchas gracias!!