Sub ExtractEmailsFromOutlookSubfolders()

Dim olApp As Object
Dim olNS As Object
Dim olInbox As Object
Dim olFolder As Object
Dim olMail As Object
Dim iRow As Long

' Create Outlook instance
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0

If olApp Is Nothing Then
MsgBox "Outlook is not available!", vbExclamation
Exit Sub
End If

Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(6) ' 6 = olFolderInbox

' Prepare Excel sheet
With Sheets(1)
.Cells.Clear
.Range("A1:E1").Value = Array("Folder", "Subject", "Received", "Sender", "EntryID")
End With
iRow = 2

' Recursively process subfolders
ProcessFolder olInbox, iRow

MsgBox "Finished extracting emails!", vbInformation

End Sub

Sub ProcessFolder(ByVal olFolder As Object, ByRef iRow As Long)
Dim olItem As Object
Dim olSubFolder As Object

' Loop through emails in this folder
For Each olItem In olFolder.Items
If TypeName(olItem) = "MailItem" Then
With Sheets(1)
.Cells(iRow, 1).Value = olFolder.FolderPath
.Cells(iRow, 2).Value = olItem.Subject
.Cells(iRow, 3).Value = olItem.ReceivedTime
.Cells(iRow, 4).Value = olItem.SenderName
.Cells(iRow, 5).Value = olItem.EntryID
End With
iRow = iRow + 1
End If
Next olItem

' Recurse into subfolders
For Each olSubFolder In olFolder.Folders
ProcessFolder olSubFolder, iRow
Next olSubFolder
End Sub