Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder
Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("vlookup")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
wb.Sheets("vlookup").Range("A2:C500").ClearContents
'i think you want column E here, not L?
lastRow = ThisWorkbook.Worksheets("vlookup").Cells(Rows.Count, "E").End(xlUp).Row
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
Set olFolder = olNs.GetDefaultFolder(olFolderInbox)
For i = olFolder.Items.Count To 1 Step -1
If TypeOf olFolder.Items(i) Is MailItem Then
Set olMail = olFolder.Items(i)
For iCounter = 2 To lastRow
If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then 'qualify the cell
With ws
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("C" & lrow + 1).Value = olMail.Body
.Range("B" & lrow + 1).Value = olMail.ReceivedTime
.Range("A" & lrow + 1).Value = olMail.SenderEmailAddress
End With
End If
Next iCounter
End If
Next i
Set olFolder = Nothing
Next eFolder
End Sub
Bookmarks