Outlook Attachments Download on bulk

[Tejpal Bisht]

I have a VBA code which helps me to download the Outlook attachment with particular outlook folder on behalf of certain data in ROW 5 (includes : Location and Folder), this code is running fine for single email but now I am receiving email on bulk, so I am trying to running the below macro on loop for every sets of data but can someone help me to sorted this

Note: I need to collect the data first on excel because there no particular email format we are using and then behalf of that data we need to save document different location


>>> use code - tags <<<

Sub Folder()
FinalRow = Range("A" & Rows.Count).End(xlUp).Row
For I = 5 To FinalRow
ThisWorkbook.Activate
  
vPath = ThisWorkbook.ActiveSheet.Range("D" & I).Value
vName = ThisWorkbook.ActiveSheet.Range("A" & I).Value
vCede = UCase(Range("B" & I).Value)
vDates = Replace(ThisWorkbook.ActiveSheet.Range("C" & I).Value, "", " ")
vMakeFolder = vPath & vName & " " & vCede & " " & vDates
MkDir vMakeFolder
  
MkDir vMakeFolder & "\1 Submission Data"
MkDir vMakeFolder & "\2 Correspondence"
MkDir vMakeFolder & "\3 GC Signed Certs_CN_Endt_ Binders_Interim"
MkDir vMakeFolder & "\4 Market Certs_CN"
MkDir vMakeFolder & "\4 Market Certs_CN\Market 1"
MkDir vMakeFolder & "\4 Market Certs_CN\Market 2"
MkDir vMakeFolder & "\5 Policy and Endts"
MkDir vMakeFolder & "\6 Invoice"
MkDir vMakeFolder & "\7 Compliance"
MkDir vMakeFolder & "\8 Diaries"
MkDir vMakeFolder & "\9 Claims"
MkDir vMakeFolder & "\9 Claims\1 Underwriting_Submission"

Call MailAttachment

Exit For

Next I

MsgBox "Done"

End Sub

----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub MailAttachment()
Dim OlApp As Outlook.Application
Dim OlFolder As Outlook.Folder
Dim OlNs As Outlook.Namespace
Dim OlMailItems As Object
Dim OlMailItem As Object
Dim DestPath As String
Dim I As Long
Set OlApp = New Outlook.Application
Set OlNs = OlApp.GetNamespace("MAPI")
    Set OlFolder = OlNs.GetDefaultFolder(olFolderInbox).Folders(Range("b2").Value)
DestPath = Range("e5").Value
Set OlMailItems = OlFolder.Items
For Each OlMailItem In OlMailItems
  
    For I = 1 To OlMailItem.Attachments.Count
        Range("a100000").End(xlUp).Offset(1, 0).Select
  
        OlMailItem.Attachments.Item(I).SaveAsFile DestPath & OlMailItem.Attachments.Item(I).Filename
    Next I
Next

End Sub