Enviar correos masivos

Con esta herramienta podrás listar en una hoja de Excel todos los correos que deseas enviar, a cada destinatario o destinatarios un asunto de correo diferente, a cada destinatario enviar uno o varios archivos, incluso podrás poner con copia a destinatarios diferentes y con copia oculta a otros destinatarios.

Puedes enviar varios archivos a varios correos o un solo archivo en varios correos a varios destinatarios.

Código en los eventos de la hoja:

--------------------------------------------------------------

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
  Dim rng As Range, t As Range
  
  Set rng = Intersect(Target, Range("B2:B" & Rows.Count))
  If Not rng Is Nothing Then
    For Each t In Target
      If t.Value <> "" Then
        ActiveSheet.Hyperlinks.Add _
          Anchor:=Cells(t.Row, "G"), Address:="", _
          SubAddress:=ActiveSheet.Name & "!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
  Dim linea As Long, col As Long
  Dim archivo As Variant
  
  linea = ActiveCell.Row
  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 = 1
    .AllowMultiSelect = True
    .InitialFileName = "c:\trabajo\pdfs"
    If .Show Then
      For Each archivo In .SelectedItems
        Cells(linea, col) = archivo
        col = col + 1
      Next
    End If
  End With
End Sub

--------------------------------------------------------------

Código en un módulo:

--------------------------------------------------------------

Option Explicit
Sub Enviar_Correos()
'Por.Dante Amor
'***Macro Para enviar correos masivos
  Dim i As Long, j As Long
  Dim dam As Object
  Dim archivo As String
  
  For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
    Set dam = CreateObject("Outlook.Application").CreateItem(0)
    '
    dam.To = Range("B" & i).Value           'Destinatarios
    dam.Cc = Range("C" & i).Value           'Con copia
    dam.Bcc = Range("D" & i).Value          'Con copia oculta
    dam.Subject = Range("E" & i).Value      'Asunto
    dam.Body = Range("F" & i).Value         'Cuerpo del mensaje
    '
    For j = Range("H1").Column To Cells(i, Columns.Count).End(xlToLeft).Column
      archivo = Cells(i, j).Value
      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

--------------------------------------------------------------

Descargar el archivo:

https://drive.google.com/file/d/11HQqHfRsOaI4GO64brudbuK8x4K3rmEF/view?usp=sharing

--------------------------------------------------------------