VBA Outlook Code - Search multiple folders and extract data

[MHamid]

Hello,

Is there a way to search two subfolders in Outlook and extract information into excel?


I have a code below that will do what I need with the exception of looking into two subfolders that I need the information from. How can I accomplish this? Will I need to have the code repeat twice per folder? I need it to search in the SUBFOLDER1 folder and in the SUBFOLDER2 folder.


Sub AARTeamTrackingMailboxPEPDeliveryEmail()

'Working macro for exporting specific sub-folders of a shared inbox
Dim olMail As Variant
Dim olRemote As Variant
Dim aOutput() As Variant
Dim lCnt As Long
Dim wkb As Workbook
Dim xlApp As Excel.Application
Dim xlSh As Excel.Worksheet
Dim flInbox As Folder
Dim lrow As Long
Dim wsTemplate As Worksheet
Dim wsRaw As Worksheet



'Gets the mailbox and shared folder inbox
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("AAR Team Tracking")

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)

'Uses the Parent of the Inbox to specify the mailbox
strFolderName = objInbox.Parent

'Specifies the folder (inbox or other) to pull the info from
Set objMailbox = objNamespace.Folders(strFolderName)
Set objFolder = objMailbox.Folders("Inbox").Folders("Delivery - PEP AARs").Folders("CB") 'specify folder
Set colItems = objFolder.Items

'Disable Alert Messages
'olApplication.DisplayAlerts = False

'Specify which email items to extract
ReDim aOutput(1 To objFolder.Items.Count, 1 To 10)
For Each olMail In objFolder.Items
If TypeName(olMail) = "MailItem" Then

lCnt = lCnt + 1
aOutput(lCnt, 1) = olMail.ReceivedTime 'stats on when received
aOutput(lCnt, 2) = olMail.Subject 'to split out
aOutput(lCnt, 3) = olMail.Sender
aOutput(lCnt, 4) = IIf(olMail.Attachments.Count > 0, "Yes", "No")
aOutput(lCnt, 5) = olMail.Categories 'to split out category
aOutput(lCnt, 6) = IIf(olMail.FlagStatus = 1, "Action Complete", "")


End If

Next


'Open Excel Template
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True

Set wkb = xlApp.Workbooks.Open("H:\jpmDesk\Desktop\Recon\Projects\2017\AAR Macro Creation\AAR Team Tracking Mailbox (PEP Delivery Email) Template.xlsx")
Set wsTemplate = wkb.Worksheets("Template")
Set wsRaw = wkb.Worksheets("Sheet1")
wsRaw.Range("A" & wsRaw.Rows.Count).End(xlUp).Offset(1).Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput

'Formula
wsTemplate.Range("B" & wsTemplate.Rows.Count).End(xlUp).Offset(1).Formula = "=Sheet1!RC[-1]"
wsTemplate.Range("C" & wsTemplate.Rows.Count).End(xlUp).Offset(1).Formula = "=Sheet1!RC[-1]"
wsTemplate.Range("D" & wsTemplate.Rows.Count).End(xlUp).Offset(1).Formula = "=Sheet1!RC[-1]"
wsTemplate.Range("E" & wsTemplate.Rows.Count).End(xlUp).Offset(1).Formula = "=Sheet1!RC[-1]"
wsTemplate.Range("F" & wsTemplate.Rows.Count).End(xlUp).Offset(1).Formula = "=IF(COUNTIF(Sheet1!RC[-1],""*,*"")>0=TRUE,MID(Sheet1!RC[-1],FIND("":"",Sheet1!RC[-1])+2,256),"""")"
wsTemplate.Range("G" & wsTemplate.Rows.Count).End(xlUp).Offset(1).Formula = "=IF(COUNTIF(Sheet1!RC[-2],""*,*"")>0=TRUE,LEFT(Sheet1!RC[-2],(FIND("","",Sheet1!RC[-2],1)-1)),Sheet1!RC[-2])"
wsTemplate.Range("H" & wsTemplate.Rows.Count).End(xlUp).Offset(1).Formula = "=IF(Sheet1!RC[-2]="""","""",Sheet1!RC[-2])"

'autofill
wsTemplate.Range("B2:H2").AutoFill Destination:=wsTemplate.Range("B2:H" & wsRaw.Range("A" & wsRaw.Rows.Count).End(xlUp).Row)
wsTemplate.Range("B2").Select




End Sub



Thank you