VBA Outlook Code - Search multiple folders and extract data

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.

Code:

---

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