Macro para enviar email con archivos de una carpeta enviando sólo los archivos que empiecen por el texto de una columna

H o l a:

Por la posición de las columnas, tal vez, te refieres a una de mis macros para enviar correos:

La macro para la aplicación es la siguiente:

'***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

Para insertar los archivos uno o varios:

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, "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.Dante Amor
    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

Envíame un correo, y te envío el archivo para que puedas adaptar los datos.

Mi correo [email protected]

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

¡Gracias! 

Te envié el correo

• Este archivo lo vi en una contestación a una pregunta. Pero lo que vi es que hay que insertar los archivos adjuntos de 1 en 1 en el hiperenlace a la carpeta donde tomar cada archivo. ¿ existe alguna macro para que esos archivos los tome automáticamente haciendo una llamada a los archivos que empiecen por el contenido de cada celda en la columna "A"? Gracias