Every few days I manually move a specified number of emails from a shared network mailbox to subfolders of team managers. They want them moved from oldest to newest. Both the managers and the number can change each time.
I wrote a script for moving a small number of emails with a specific subject line in the folder to a subfolder to be worked by a certain group.
I have tried to adapt this to my current task.
Sub Moverdaily()
On Error GoTo errHandler
Dim olApp As Outlook.Application
Dim objNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim manager= As Outlook.MAPIFolder
Dim cell,start,finish,rng As Range
Dim countE,countM As Integer
Dim emcount, casecount, movedcount
Set rng = Range(Range("A2"), Range("A2").End(xlDown))
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.Folders("Documents").Folders("Inbox")
Set manager = objNS.Folders("Document").Folders("Inbox").Folders("Manager")
Set finish = ThisWorkbook.Sheets("Mover").Range("I11")
Set start = ThisWorkbook.Sheets("Mover").Range("I10")
start.Value = Format(Now, "hh:mm:ss")
Set emcount = Range("I12")
Set casecount = Range("I13")
Set movedcount = Range("I14")
countM = 0
countE = 0
For i = olFolder.Items.count To 1 Step -1
For Each cell In rng
If (cell.Text = (onlyDigits(msg.Subject))) Then
msg.move manager
countM = 1 + countM
cell.Offset(0, 1).Value = "Moved"
End If
Next
countE = 1 + countE
Next
finish.Value = Format(Now, "hh:mm:ss")
emcount.Value = countE
casecount.Value = rng.count
movedcount.Value = countM
errHandler:
MsgBox ("Error " & Err.Number & ": " & Err.Description)
Exit Sub
End Sub
Firstly, do not use "for each" with a collection that you change - MailItem.Mpve removes an itemn from that collection. Use a for i = Items.Count to 1 step -1 instead.
Secondly, do not loop through all item - if you already know the entry ids (rngarry), simply call Namespace.GetItemfromID.
Related
I'm trying to save the Outlook attachment from a particular sub folder to a local path.
I'm able to save the file as is to the local path.
The requirement is to save the xl attachment using a cell value of ThisWorkbook as the file name.
Sub ManualPunchAttachmentsExtract()
Dim OlFolder As Outlook.MAPIFolder
Dim OlMail As Object
Dim OlApp As Outlook.Application
Dim OlItems As Outlook.Items
Dim Get_namespace As Outlook.Namespace
Dim strFolder As String
Dim i As Integer
ThisWorkbook.Activate
Sheets("MP File Save").Activate
Range("H3").Activate
Set OlApp = GetObject(, "Outlook.Application")
If err.Number = 429 Then
Set OlApp = CreateObject("Outlook.Application")
End If
strFolder = InputBox("Please Enter the Folder Path alongwith ' \ ' at the end", Path)
'Set Get_namespace = OlApp.GetNamespace("MAPI")
Set OlFolder = OlApp.GetNamespace("MAPI").Folders("shaikajaz.k#flex.com").Folders("Archive").Folders("Juarez").Folders("Manual Punch")
Set OlItems = OlFolder.Items
'.Restrict("[Unread]=true")
For Each OlMail In OlItems
If OlMail.UnRead = False Then
Else
ThisWorkbook.Activate
Sheets("MP File Save").Activate
ActiveCell.Value = OlMail.Subject
ActiveCell.Offset(0, 1).Value = OlMail.ReceivedTime
If OlMail.attachments.Count > 0 Then
For i = 1 To OlMail.attachments.Count
OlMail.attachments.Item(i).SaveAsFile strFolder & "\" & OlMail.attachments.Item(i).FileName
OlMail.UnRead = False
ThisWorkbook.Activate
ActiveCell.Offset(1, 0).Select
Next i
Else
End If
End If
Next
MsgBox ("Done")
End Sub
First of all, iterating over all items in an Outlook folder is not realy a good idea. Use the Find/FindNext or Restrict methods of the Items class instead. So, instead of the following code:
For Each OlMail In OlItems
If OlMail.UnRead = False Then
Use this:
Private Sub FindAllUnreadEmails(folder As Outlook.MAPIFolder)
Dim searchCriteria As String = "[UnRead] = true"
Dim counter As Integer = 0
Dim mail As Outlook._MailItem = Nothing
Dim folderItems As Outlook.Items = Nothing
Dim resultItem As Object = Nothing
If (folder.UnReadItemCount > 0) Then
folderItems = folder.Items
resultItem = folderItems.Find(searchCriteria)
While Not IsNothing(resultItem)
If (TypeOf (resultItem) Is Outlook._MailItem) Then
counter += 1
mail = resultItem
Debug.Print("#" + counter.ToString() + _
" - Subject: " + mail.Subject)
End If
resultItem = folderItems.FindNext()
End While
Else
Debug.Print("There is no match in the " + _
folder.Name + " folder.")
End If
End Sub
Note, attached files can have the same file name. So, to uniquelly identify files I'd suggest introducing any IDs in the file name when attachments are saved to the disk.
Finally, to save the attached file with a workbook's content name you need to pass a cell value to the SaveAsFile method:
OlMail.attachments.Item(i).SaveAsFile strFolder & "\" & yourWorksheet.Range("B2").Value
I have an excel macro that works perfect in windows (email text extraction), but when I run it in my mac it gives me the error missing the library Microsoft Outlook 16.0 Object Library.
I was thinking in late binding (I tried but I wasn't able to fix it)
Can you pls help me to fix my code in order to run it in my mac? thanks in advance.
Code Below:
Sub DetailExtraction() 'MacVersion
On Error GoTo ErrHandler
Application.ScreenUpdating = False
' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
' CREATE AND SET A NameSpace OBJECT.
Dim objNSpace As Object
' THE GetNameSpace() METHOD WILL REPRESENT A SPECIFIED NAMESPACE.
Set objNSpace = objOutlook.GetNamespace("MAPI")
' CREATE A FOLDER OBJECT.
Dim myFolder As Object
Set myFolder = objNSpace.GetDefaultFolder(olFolderInbox)
Dim Item As Object
Dim iRows, iCols As Integer
iRows = 2
' LOOP THROUGH EACH ITEMS IN THE FOLDER.
'For Each objItem In myFolder.Items
' LOOP THROUGH EACH ITEMS IN THE SELECTION.
For Each objItem In ActiveExplorer.Selection
If objItem.Class = olMail Then
Dim objMail As Outlook.MailItem ' PROBLEM IS IN THIS LINE
Set objMail = objItem
Cells(iRows, 1) = objMail.SenderEmailAddress
Cells(iRows, 2) = objMail.To
Cells(iRows, 3) = objMail.Subject
Cells(iRows, 4) = objMail.ReceivedTime
Cells(iRows, 6) = objMail.Body
Cells(iRows, 6).WrapText = False
'MsgBox Prompt:=objMail.Body
End If
'WRAP UP FILE OFF
' Cells*i.WrapText = False
' SHOW OTHER PROPERTIES, IF YOU WISH.
'Cells(iRows, 6) = objMail.Body
'Cells(iRows, 5) = objMail.CC
'Cells(iRows, 6) = objMail.BCC
'Cells(iRows, 4) = objMail.Recipients(1)
iRows = iRows + 1
Next
Set objMail = Nothing
' RELEASE.
Set objOutlook = Nothing
Set objNSpace = Nothing
Set myFolder = Nothing
ErrHandler:
Debug.Print Err.Description
Application.ScreenUpdating = True
MsgBox "Environments Details Extracted from the Selected Emails (" & iRows - 2 & ")"
End Sub
My mails in Outlook has all specific subjects. I have a Excel Sheet which has subject and Folder Name.
I have already this code from Stackoverflow
Option Explicit
Public Sub Move_Items()
'// Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Item As Object
Dim lngCount As Long
Dim Items As Outlook.Items
On Error GoTo MsgErr
'// Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
'// Loop through the Items in the folder backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items.Item(lngCount)
Debug.Print Item.Subject
If Item.Class = olMail Then
'// Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
'// Mark As Read
Item.UnRead = False
'// Move Mail Item to sub Folder
Item.Move SubFolder
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
I want the code to read the active sheet columns, as follow:
Subject.mail folder_name
A 1
B 2
C 3
For example Mail in the Inbox with subject "A" then it has to place that mail in folder "1".
How do I loop? to look at the Sheet1 and to read to which sub folder it has to move ?
You have few options to do this, the painless one is to run Outlook VBA code from inside outlook so you don't need to go through a lot of referencing problem, but at the same time if you are insisting in having your list of subjects and folder in an Excel file, then it is better to run it from Excel, but here is the issue: You'd better not try to run the code from Excel because Microsoft is not supporting that method, so the best way is to write the code in Excel VBA, and again you can do late (runtime) binding or early binding, but I prefer early binding to use intellisence for better referencing outlook objects and avoid late binding performance and/or debugging problems.
Here is the code and how you should use it:
Go to the excel file that you have your subject and folders list or create a new one. Hit ALT+F11 to go to VBE. On the left panel (project explorer) right click and insert a module. Paste this code in there:
Option Explicit
Public Sub MoveEmailsToFolders()
'arr will be a 2D array sitting in an Excel file, 1st col=subject, 2nd col=folder name
' // Declare your Variables
Dim i As Long
Dim rowCount As Integer
Dim strSubjec As String
Dim strFolder As String
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim myFolder As Outlook.Folder
Dim Item As Object
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim lngCount As Long
Dim Items As Outlook.Items
Dim arr() As Variant 'store Excel table as an array for faster iterations
Dim WS As Worksheet
'On Error GoTo MsgErr
'Set Excel references
Set WS = ActiveSheet
If WS.ListObjects.Count = 0 Then
MsgBox "Activesheet did not have the Excel table containing Subjects and Outlook Folder Names", vbCritical, "Error"
Exit Sub
Else
arr = WS.ListObjects(1).DataBodyRange.Value
rowCount = UBound(arr, 2)
If rowCount = 0 Then
MsgBox "Excel table does not have rows.", vbCritical, "Error"
Exit Sub
End If
End If
'Set Outlook Inbox Reference
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set myFolder = olNs.GetDefaultFolder(olFolderInbox)
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
' // Loop through the Items in the folder backwards
For lngCount = Items.Count To 1 Step -1
strFolder = ""
Set Item = Items.Item(lngCount)
'Debug.Print Item.Subject
If Item.Class = olMail Then
'Determine whether subject is among the subjects in the Excel table
For i = 1 To rowCount
If arr(i, 1) = Item.Subject Then
strFolder = arr(i, 2)
'// Set SubFolder of Inbox, read the appropriate folder name from table in Excel
Set SubFolder = Inbox.Folders(strFolder)
'// Mark As Read
Item.UnRead = False
'// Move Mail Item to sub Folder
Item.Move SubFolder
Exit For
End If
Next i
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
Set Reference:
To use outlook objects, in Excel VBE go to Tools, References and check Microsoft Outlook object library.
Set Excel Sheet:
In an Excel sheet, create a table with two columns that the first column contains email subjects and the second column contains folders to which you want those emails to be moved.
Then, insert a shape and right click on that and Assign a Macro, find the name of the macro (MoveEmailsToFolders) and click ok.
Suggestions:
You can develop the code more to disregard matchcase. To do that replace this line:
arr(i, 1) = Item.Subject
with:
Ucase(arr(i, 1)) = Ucase(Item.Subject)
Also, you can move the emails that contain the subject rather than matching an exact title, for example if an email subject had "test", or begins with "test", or ends with "test", then move it to the corresponding folder. Then, the comparison clause would be:
If arr(i, 1) Like Item.Subject & "*" Then 'begins with
If arr(i, 1) Like "*" & Item.Subject & "*" Then 'contains
If arr(i, 1) Like "*" & Item.Subject Then 'ends with
Hope this helps! Please hit the check mark to make this as the right answer to your questions if it did
I would use an explicit reference to your sheet instead of ActiveSheet unless you are actually running the Macro on a bunch of different sheets. And I'm just assuming your data is in column A and B and starts at row 2 for examples sake. This is how you would loop through your data and trying to match the subject, then move it to a folder with the name in the next column if it matches.
If Item.Class = olMail Then
For i = 2 To ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
If ActiveSheet.Range("A" & i).Value = Item.Subject Then
'// Set SubFolder of Inbox
Set SubFolder = Inbox.Folders(ActiveSheet.Range("B" & i).Value)
'// Mark As Read
Item.UnRead = False
'// Move Mail Item to sub Folder
Item.Move SubFolder
End If
Next
End If
There are ways you could check without using a loop as well such as the Find method
Dim rnFind As Range
If Item.Class = olMail Then
Set rnFind = ActiveSheet.Range("A2", ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp)).Find(Item.Subject)
If Not rnFind Is Nothing Then
'// Set SubFolder of Inbox
Set SubFolder = Inbox.Folders(rnFind.Offset(, 1).Value)
'// Mark As Read
Item.UnRead = False
'// Move Mail Item to sub Folder
Item.Move SubFolder
End If
End If
Use Do Until IsEmpty loop, Make sure to set Excel Object Referees...
See Example on how to loop from Outlook...
Option Explicit
Public Sub Move_Items()
'// Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Items As Outlook.Items
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim Item As Object
Dim ItemSubject As String
Dim SubFldr As String
Dim lngCount As Long
Dim lngRow As Long
On Error GoTo MsgErr
'// Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
'// Excel Book Reference
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Open("C:\Temp\Book1.xlsx") ' Excel Book Path
lngRow = 2 ' Start Row
With xlBook.Worksheets("Sheet1") ' Sheet Name
Do Until IsEmpty(.Cells(lngRow, 1))
ItemSubject = .Cells(lngRow, 1).Value ' Subject
SubFldr = .Cells(lngRow, 2).Value ' Folder Name
'// Loop through the Items in the folder backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items.Item(lngCount)
If Item.Class = olMail Then
If Item.Subject = ItemSubject Then
Debug.Print Item.Subject
Set SubFolder = Inbox.Folders(SubFldr) ' Set SubFolder
Debug.Print SubFolder
Item.UnRead = False ' Mark As Read
Item.Move SubFolder ' Move to sub Folder
End If
End If
Next
lngRow = lngRow + 1
Loop
End With
xlBook.Close
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set xlApp = Nothing
Set xlBook = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
with the below VBA coding, I am able to send all the emails from outlook draft folder but the only problem is that I have to provide the parent folder name. Can we get this details through coding as this macro will be used by other user who is not familiar with VBA.
Dim lDraftItem As Long
Dim myOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolders As Outlook.Folders
Dim myDraftsFolder As Outlook.MAPIFolder
Set myOutlook = Outlook.Application
Set myNameSpace = myOutlook.GetNamespace("MAPI")
Set myFolders = myNameSpace.Folders
Set myDraftsFolder = myFolders("Gaus_Shaikh2#syntelinc.com").Folders("Drafts")
For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
If Len(Trim(myDraftsFolder.Items.Item(lDraftItem).To)) > 0 Then
myDraftsFolder.Items.Item(lDraftItem).Send
End If
Next lDraftItem
This should work...
Set myDraftsFolder = myNamespace.GetDefaultFolder(olFolderDrafts)
* Edit *
The code below is probably a better function to use; it has error checking incorporated so any e-mails with invalid fields in the 'To' section shouldn't abort the function
Sub TestSendDrafts()
Call SendDraftMail
End Sub
Function SendDraftMail() As Boolean
On Error GoTo ExitFunction
Dim ThisNameSpace As Outlook.NameSpace: Set ThisNameSpace = Application.GetNamespace("MAPI")
Dim DraftFolder As Outlook.MAPIFolder: Set DraftFolder = ThisNameSpace.GetDefaultFolder(olFolderDrafts)
Dim Var As Variant, i As Long, Difference As Long, SentItems As Long
For i = DraftFolder.Items.Count To 1 Step -1
Set Var = DraftFolder.Items.Item(i)
DoEvents
If Var.Class = olMail Then
If Len(Trim(Var.To)) > 0 Then
On Error Resume Next
Var.Send
If Err.Number = 0 Then SentItems = SentItems + 1
On Error GoTo ExitFunction
End If
End If
Next i
Debug.Print "Sent " & SentItems & " message(s) from 'Draft E-mail'."
SendDraftMail = True
ExitFunction:
End Function
Replace this line:
Set myDraftsFolder = myFolders("Gaus_Shaikh2#syntelinc.com").Folders("Drafts")
With these three lines:
Dim sUser As String
sUser = myFolders.Item(2).Name
Set myDraftsFolder = myFolders(sUser).Folders("Drafts")
The 2nd folder name will be the user account name (e-mail address), which you can store as a string and pass into myFolders() to qualify their specific account.
I am to write a VBA code that would retrive emails from Outlook based on certain conditions. The problem I have is that I have to denote a certain folder in my code (in the example below the folder denoted is "PRE Costumer". I would like to retrive all emails from my 'inbox' or in better case from all outlook folders. The problem is that my inbox consists of many subfolders (because of rules0. My problem is that I may not know all the subfolders names (as many useres are going to use the macro and even someone can have the e mails in Personal Folders).
Could you please advise is there a way to overcome this problem?
Please let me know if this question is vague (as I am newcomer)
Please find the line that I have probelm with marked with a comment.
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
'Below is the line I have problem with
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
i = 1
x = Date
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "transactions") > 0 _
And InStr(olMail.ReceivedTime, x) > 0 Then
ActiveSheet.Cells(i, 1).Value = olMail.Subject
ActiveSheet.Cells(i, 2).Value = olMail.ReceivedTime
ActiveSheet.Cells(i, 3).Value = olMail.SenderName
i = i + 1
End If
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Just loop through all the folders in Inbox.
Something like this would work.
Edit1: This will avoid blank rows.
Sub test()
Dim olApp As Outlook.Application, olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder '~~> additional declaration
Dim i As Long
Dim x As Date, ws As Worksheet '~~> declare WS variable instead
Dim lrow As Long '~~> additional declaration
Set ws = Activesheet '~~> or you can be more explicit using the next line
'Set ws = Thisworkbook.Sheets("YourTargetSheet")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = Date
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
'Debug.Print eFolder.Name
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name)
For i = olFolder.Items.Count To 1 Step -1
If TypeOf olFolder.Items(i) Is MailItem Then
Set olMail = olFolder.Items(i)
If InStr(olMail.Subject, "transactions") > 0 _
And InStr(olMail.ReceivedTime, x) > 0 Then
With ws
lrow = .Range("A" & .Rows.Count).End(xlup).Row
.Range("A" & lrow).Offset(1,0).value = olMail.Subject
.Range("A" & lrow).Offset(1,1).Value = olMail.ReceivedTime
.Range("A" & lrow).Offset(1,2).Value = olMail.SenderName
End With
End If
End If
Next i
Set olFolder = Nothing
Next eFolder
End Sub
Above takes care of all subfolders in Inbox.
Is this what you're trying?
To fix your error (olFolderInbox is a Outlook only constant, so you need to define it in vba that is not Outlook):
Const olFolderInbox = 6
'...
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
Also to prevent missing Reference when run from another computer, I would:
Dim olApp As Object
Dim olNs As Object
Dim Fldr As Object
Dim olMail As Object
Dim i As Long
Set olApp = CreateObject("Outlook.Application")
'...
You might also want to disable ScreenUpdating, then enable it in Excel if you expect a long list.
UPDATE (Solution for all folders from a Root Folder)
I used something slightly different for comparing the dates.
Option Explicit
Private lRow As Long, x As Date, oWS As Worksheet
Sub GetFromInbox()
Const olFolderInbox = 6
Dim olApp As Object, olNs As Object
Dim oRootFldr As Object ' Root folder to start
Dim lCalcMode As Long
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set oRootFldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
Set oWS = ActiveSheet
x = Date
lRow = 1
lCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
GetFromFolder oRootFldr
Application.ScreenUpdating = True
Application.Calculation = lCalcMode
Set oWS = Nothing
Set oRootFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Private Sub GetFromFolder(oFldr As Object)
Dim oItem As Object, oSubFldr As Object
' Process all mail items in this folder
For Each oItem In oFldr.Items
If TypeName(oItem) = "MailItem" Then
With oItem
If InStr(1, .Subject, "transactions", vbTextCompare) > 0 And DateDiff("d", .ReceivedTime, x) = 0 Then
oWS.Cells(lRow, 1).Value = .Subject
oWS.Cells(lRow, 2).Value = .ReceivedTime
oWS.Cells(lRow, 3).Value = .SenderName
lRow = lRow + 1
End If
End With
End If
Next
' Recurse all Subfolders
For Each oSubFldr In oFldr.Folders
GetFromFolder oSubFldr
Next
End Sub