Macro para enviar Correos masivos, saber cuales se enviaron!

Supongo que tienes esta macro.

Le hice un cambio para que te pinte la celda de rojo si el archivo no existe

Sub Enviar_Correos()
'---
'   Por.Dante Amor
'---
    '***Macro Para enviar correos
    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).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 = col To Cells(i, Columns.Count).End(xlToLeft).Column
            Cells(i, j).Interior.ColorIndex = xlNone
            archivo = Cells(i, j).Value
            If Dir(archivo) <> "" Then
                dam.Attachments.Add archivo
            Else
                Cells(i, j).Interior.ColorIndex = 3
            End If
        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

.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

.

Avísame cualquier duda

.

Utiliza esta:

Sub Enviar_Correos()
'---
'   Por.Dante Amor
'---
    '***Macro Para enviar correos
    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).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 = col To Cells(i, Columns.Count).End(xlToLeft).Column
            Cells(i, j).Interior.ColorIndex = xlNone
            archivo = Cells(i, j).Value
            If Dir(archivo) <> "" Then
                dam.Attachments.Add archivo
            Else
                Cells(i, j).Interior.ColorIndex = 3
            End If
        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

.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

.

Avísame cualquier duda

.

Dante pues en realidad tengo este código

Dim AppSaliente, CorreoSaliente As Object
Dim HojaCalculo As Worksheet
Dim celda, CeldArchivo, rango As Range

With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set HojaCalculo = Sheets("Correo")
Set AppSaliente = CreateObject("Outlook.Application")
For Each celda In HojaCalculo.Columns("B").Cells.SpecialCells(xlCellTypeVisible)
'Poner los nombres en las columnas C:Z de cada fila
Set rango = HojaCalculo.Cells(celda.Row, 1).Range("C1:bZ1")
If celda.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rango) > 0 Then
Set CorreoSaliente = AppSaliente.CreateItem(0)
With CorreoSaliente
.to = celda.Value
.Subject = Worksheets("Hoja1").Range("A2")
.Body = ""
'.Attachments.Add ActiveWorkbook.FullName
For Each CeldArchivo In rango.SpecialCells(xlCellTypeVisible)
If Trim(CeldArchivo) <> "" Then
If Dir(CeldArchivo.Value) <> "" Then
.Attachments.Add CeldArchivo.Value
End If
End If
Next CeldArchivo
'Display
.Send 'para enviar sin comprobar
End With
Set CorreoSaliente = Nothing
End If
Next celda
Set AppSaliente = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End If

Pues quisiera editar ese así como lo que dices de que se marque en rojo

Te anexo la macro actualizada

Sub Correo()
    Dim AppSaliente, CorreoSaliente As Object
    Dim HojaCalculo As Worksheet
    Dim celda, CeldArchivo, rango As Range
    With Application
    .EnableEvents = False
    .ScreenUpdating = False
    End With
    Set HojaCalculo = Sheets("Correo")
    Set AppSaliente = CreateObject("Outlook.Application")
    For Each celda In HojaCalculo.Columns("B").Cells.SpecialCells(xlCellTypeVisible)
    'Poner los nombres en las columnas C:Z de cada fila
    Set rango = HojaCalculo.Cells(celda.Row, 1).Range("C1:bZ1")
    If celda.Value Like "?*@?*.?*" And _
    Application.WorksheetFunction.CountA(rango) > 0 Then
        Set CorreoSaliente = AppSaliente.CreateItem(0)
        With CorreoSaliente
            .to = celda.Value
            .Subject = Worksheets("Hoja1").Range("A2")
            .Body = ""
            '.Attachments.Add ActiveWorkbook.FullName
            For Each CeldArchivo In rango.SpecialCells(xlCellTypeVisible)
                If Trim(CeldArchivo) <> "" Then
                    If Dir(CeldArchivo.Value) <> "" Then
                        .Attachments.Add CeldArchivo.Value
                    Else
                        CeldArchivo.Interior.ColorIndex = 3
                    End If
                End If
            Next CeldArchivo
            'Display
            .Send 'para enviar sin comprobar
            End With
            Set CorreoSaliente = Nothing
            End If
            Next celda
            Set AppSaliente = Nothing
            With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End If
End Sub

.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

.

Avísame cualquier duda

.

Dante, buen día, ¿El código funciona Excelente pero no se podría hacer para que envíe un msgbox con los pdf que no encontraron o algo así?