Boa tarde!

Eu não uso excel para nada, ainda mais agora (que fui promovido para o TI-Infra), tem coisas que nunca usei dentro dessa ferramenta poderosa, mais segue ai algo que talvez possa ajuda-lo

Sub TenteAdaptar() 
     
    Dim olApp As Outlook.Application 
    Dim olNs As Outlook.Namespace 
    Dim olFldr As Outlook.MAPIFolder 
    Dim olItms As Outlook.Items 
    Dim olMail As Variant 
    Dim i As Long 
     
    Set olApp = New Outlook.Application 
    Set olNs = olApp.GetNamespace(”MAPI”) 
    Set olFldr = olNs.GetDefaultFolder(olFolderInbox) 
    Set olItms = olFldr.Items 
     
    olItms.Sort “Subject” 
     
    i = 1 
     
    For Each olMail In olItms 
        If InStr(olMail.Subject, “[COLOR="green"]Criteria[/COLOR]”) > 0 Then 
            [COLOR="green"]ThisWorkbook[/COLOR].Sheets("[COLOR="green"]YourSheet[/COLOR]").Cells(i, 1).Value = outMail.Body 
            i = i + 1 
        End If 
    Next olMail 
     
    Set olFldr = Nothing 
    Set olNs = Nothing 
    Set olApp = Nothing 
     
End Sub 

Leia também:
http://msdn.microsoft.com/en-us/library ... =office.11).aspx
http://www.cpearson.com/excel/Email.aspx

Sub EMail_PlanilhaAtiva() 
     'Working in 2000-2007
    Dim Source As Range 
    Dim Dest As Workbook 
    Dim wb As Workbook 
    Dim TempFilePath As String 
    Dim TempFileName As String 
    Dim FileExtStr As String 
    Dim FileFormatNum As Long 
    Dim OutApp As Object 
    Dim OutMail As Object 
     
    Set Source = Nothing 
    On Error Resume Next 
     
    Set Source = Sheets("Charity Calendar").Range("A1:At91").SpecialCells(xlCellTypeVisible) 
     
    On Error Goto 0 
     
    If Source Is Nothing Then 
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly 
        Exit Sub 
    End If 
     
    With Application 
        .ScreenUpdating = False 
        .EnableEvents = False 
    End With 
     
    Set wb = ActiveWorkbook 
    Set Dest = Workbooks.Add(xlWBATWorksheet) 
    Source.Copy 
     
    With Dest.Sheets(1) 
         
        .Cells(1).PasteSpecial Paste:=8 
        .Cells(1).PasteSpecial Paste:=xlPasteValues 
        .Cells(1).PasteSpecial Paste:=xlPasteFormats 
        .Cells(1).Select 
        Application.CutCopyMode = False 
    End With 
     
    TempFilePath = Environ$("temp") & "" 
    TempFileName = Sheets("email data").Range("c11") & " " & Format(Now, "dd-mmm-yy ") 
     
    If Val(Application.Version) < 12 Then 
         'You use Excel 2000-2003
        FileExtStr = ".xls": FileFormatNum = -4143 
    Else 
         'You use Excel 2007
        FileExtStr = ".xlsx": FileFormatNum = 51 
    End If 
     
    Set OutApp = CreateObject("Outlook.Application") 
    OutApp.Session.Logon 
    Set OutMail = OutApp.CreateItem(0) 
     
    With Dest 
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum 
        On Error Resume Next 
        With OutMail 
            .To = Sheets("email data").Range("C9") 
            .CC = Sheets("email data").Range("C12") & "; " & Sheets("email data").Range("C13") & "; " & Sheets("email data").Range("C14") & "; " & Sheets("email data").Range("C15") 
            .BCC = Sheets("email data").Range("C16") 
            .Subject = Sheets("email data").Range("C11") 
             
            .Body = "F.A.O" & " " & Sheets("email data").Range("C17") & vbNewLine & vbNewLine & _ 
            Sheets("email data").Range("C18") & vbNewLine & vbNewLine & _ 
            Sheets("email data").Range("C19") & vbNewLine & _ 
            Sheets("email data").Range("C20") & vbNewLine & _ 
            Sheets("email data").Range("C21") & vbNewLine & _ 
            Sheets("email data").Range("C22") & vbNewLine & _ 
            Sheets("email data").Range("C23") & vbNewLine & _ 
            Sheets("email data").Range("C24") & vbNewLine & _ 
            Sheets("email data").Range("C25") & vbNewLine & _ 
            Sheets("email data").Range("C26") & vbNewLine & _ 
            Sheets("email data").Range("C27") & vbNewLine & _ 
            Sheets("email data").Range("C28") & vbNewLine & _ 
            Sheets("email data").Range("C29") & vbNewLine & _ 
            Sheets("email data").Range("C30") & vbNewLine & _ 
            Sheets("email data").Range("C31") & vbNewLine & _ 
            Sheets("email data").Range("C32") & vbNewLine & _ 
            Sheets("email data").Range("C33") & vbNewLine & _ 
            Sheets("email data").Range("C34") & vbNewLine & _ 
            Sheets("email data").Range("C35") & vbNewLine & _ 
            Sheets("email data").Range("C36") & vbNewLine & _ 
            Sheets("email data").Range("C37") & vbNewLine & _ 
            "" & vbNewLine & vbNewLine 
             ' .Attachments.Add Destwb.FullName
            .Attachments.Add Dest.FullName 
             
             'You can add other files also like this
             '.Attachments.Add ("C:test.txt")
            .Send 
             '.Display
        End With 
        On Error Goto 0 
        .Close SaveChanges:=False 
         
    End With 
     
    Kill TempFilePath & TempFileName & FileExtStr 
     
    Set OutMail = Nothing 
    Set OutApp = Nothing 
     
    With Application 
        .ScreenUpdating = True 
        .EnableEvents = True 
    End With 
     
     
End Sub 

Att