Enviar correos con condición

Tienes una lista de registros y quieres enviarle un correo a cada destinatario dependiendo de una condición. 

Código VBA:

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

Sub Enviar_Correos()

'Por.Dante Amor

  Dim i As Long

  Dim dam As Object

  

  For i = 2 To Range("A" & Rows.Count).End(xlUp).Row

    If Range("E" & i).Value = "Pendiente" Then

      

      Set dam = CreateObject("outlook.application").createitem(0)

      

      dam.To = Range("B" & i).Value 'Destinatarios

      dam.Subject = "Pendientes"

      dam.Body = "Buen día : " & Range("A" & i).Value & vbCr & _

        "Tiene pendiente el siguiente: " & Range("C" & i).Value

      

      dam.Display 'El correo se muestra

    End If

  Next

  MsgBox "Correos enviados"

End Sub

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

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

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

Enviar correos de calificaciones en automático

Te gustaría aprender cómo enviar por correo la calificación a cada uno de tus alumnos.

Tienes que pasar cada calificación a un formato, guardarlo como archivo pdf y enviar el archivo por correo a cada alumno.

Eso te lleva MUCHO tiempo y en ocasiones te faltaron correos o no está la información completa.

Revisa el vídeo, ahí te explico cómo enviar correos en automático.

Código para enviar correos:

Sub EnviarCalificaciones()

'Por Dante Amor

  Dim c As Range

  Dim matricula As Range, nombre As Range, evaluacion As Range, curso As Range

  Dim sh2 As Worksheet

  Dim dam As Object

  Dim archivo As String, columnaCorreo  As String, sArea As String

  Application.ScreenUpdating = False

  Application.DisplayAlerts = False

  '

  'Parámetros

  Set curso = [A4]          'celda con el nombre del curso

  Set matricula = [B6]      'celda con la matrícula

  Set nombre = [E6]         'celda con el nombre del alumno

  Set evaluacion = [B8]     'celda con la evaluación

  columnaCorreo = "G"

  '

  sArea = ActiveSheet.PageSetup.PrintArea

  For Each c In Range("matriculas")

    matricula.Value = c.Value

    archivo = ThisWorkbook.Path & "\" & matricula.Value & ".pdf"

    Range(sArea).ExportAsFixedFormat xlTypePDF, archivo

    

    Set dam = CreateObject("outlook.application").createitem(0)

    dam.To = Sheets(c.Parent.Name).Range(columnaCorreo & c.Row).Value

    dam.Subject = "Evaluación " & evaluacion.Value & _

                  ", " & nombre.Value

    dam.body = "Buen día, en el archivo encontrarás " & _

               "el resultado de tu evaluación del curso : " & curso.Value & vbCr & _

               "Saludos"

    dam.Attachments.Add archivo

    'dam.Display  'El correo se muestra

    dam.Send

  Next

  MsgBox "Calificaciones Enviadas", vbInformation, "Excel y Macros"

End Sub