Te anexo la macro
Sub EnviarCorreos()
'Por.Dante Amor
Set h1 = Sheets("Contactos")
ruta = ThisWorkbook.Path & "\"
For Each h In Sheets
If h.Name <> h1.Name Then
Set b = h1.Columns("B").Find(h.Range("C4"), lookat:=xlWhole)
If Not b Is Nothing Then
correo = h1.Cells(b.Row, "D")
h.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ruta & "archivo.pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
'
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = correo
dam.Subject = "Envío de hoja"
dam.body = "Se envía archivo en PDF"
dam.Attachments.Add ruta & "archivo.pdf"
'dam.Display
dam.Send 'El correo se envía en automático
End If
End If
Next
MsgBox "fin"
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias