Note: The other languages of the website are Google-translated. Back to English
Log in  \/ 
x
or
x
Register  \/ 
x

or

How to export emails from multiple folders/subfolders to excel in Outlook?

When exporting a folder with the Import and Export wizard in Outlook, it does not support the Include Subfolders option if you export the folder to CSV file. However, it will be quite time-consuming and tedious to export each folder to CSV file and then convert it to Excel workbook manually. Here, this article will introduce a VBA to quickly export multiple folders and subfolders to Excel workbooks at ease.

Export multiple emails from multiple folders/subfolders to Excel with VBA

Office Tab - Enable Tabbed Editing and Browsing in Office, and Make Work Much Easier...
Kutools for Outlook - Brings 100 Powerful Advanced Features to Microsoft Outlook
  • Auto CC/BCC by rules when sending email; Auto Forward Multiple Emails by rules; Auto Reply without exchange server, and more automatic features...
  • BCC Warning - show message when you try to reply all if your mail address is in the BCC list; Remind When Missing Attachments, and more remind features...
  • Reply (All) With All Attachments in the mail conversation; Reply Many Emails at once; Auto Add Greeting when reply; Auto Add Date&Time into subject...
  • Attachment Tools: Auto Detach, Compress All, Rename All, Auto Save All... Quick Report, Count Selected Mails, Remove Duplicate Mails and Contacts...
  • More than 100 advanced features will solve most of your problems in Outlook 2010-2019 and 365. Full features 60-day free trial.

arrow blue right bubble Export multiple emails from multiple folders/subfolders to Excel with VBA

Please follow below steps to export emails from multiple folders or subfolders to Excel workbooks with VBA in Outlook.

1. Press Alt + F11 keys to open the Microsoft Visual Basic for Applications window.

2. Click Insert > Module, and then paste below VBA code into the new Module window.

VBA: Export emails from multiple folders and subfolders to Excel

Const MACRO_NAME = "Export Outlook Folders to Excel"

Sub ExportMain()
ExportToExcel "destination_folder_path\A.xlsx", "your_email_accouny\folder\subfolder_1"
ExportToExcel "destination_folder_path\B.xlsx", "your_email_accouny\folder\subfolder_2"
MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub
Sub ExportToExcel(strFilename As String, strFolderPath As String)
Dim      olkMsg As Object
Dim olkFld As Object
Dim excApp As Object
Dim excWkb As Object
Dim excWks As Object
Dim intRow As Integer
Dim intVersion As Integer

If strFilename <> "" Then
If strFolderPath <> "" Then
Set olkFld = OpenOutlookFolder(strFolderPath)
If TypeName(olkFld) <> "Nothing" Then
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet
'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Received"
.Cells(1, 3) = "Sender"
End With
intRow = 2
For Each olkMsg In olkFld.Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
intRow = intRow + 1
End If
Next
Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
Else
MsgBox "The folder '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
End If
Else
MsgBox "The folder path was empty.", vbCritical + vbOKOnly, MACRO_NAME
End If
Else
MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
End If

Set olkMsg = Nothing
Set olkFld = Nothing
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
End Sub

Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
Dim arrFolders As Variant
Dim varFolder As Variant
Dim bolBeyondRoot As Boolean

On Error Resume Next
If strFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
Do While Left(strFolderPath, 1) = "\"
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
Loop
arrFolders = Split(strFolderPath, "\")
For Each varFolder In arrFolders
Select Case bolBeyondRoot
Case False
Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
bolBeyondRoot = True
Case True
Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
End Select
If Err.Number <> 0 Then
Set OpenOutlookFolder = Nothing
Exit For
End If
Next
End If
On Error GoTo 0
End Function

Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry
Dim olkEnt As Object

On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTPEX(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function

Function SMTPEX(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.propertyAccessor
On Error Resume Next
Set olkPA = olkMsg.propertyAccessor
SMTPEX = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function

3. Please adjust the above VBA code as you need.

(1) Replace destination_folder_path in above code with the folder path of destination folder you will save the exported workbooks in, such as C:\Users\DT168\Documents\TEST.
(2) Replace your_email_accouny\folder\subfolder_1 and your_email_accouny\folder\subfolder_2 in above code with the folder paths of subfolders in Outlook, such as Kelly@extendoffice.com\Inbox\A and Kelly@extendoffice.com\Inbox\B

4. Press the F5 key or click the Run button to run this VBA. And then click the OK button in the popping out Export Outlook Folders to Excel dialog box. See screenshot:

And now emails from all specified subfolders or folders in above VBA code are exported and saved into Excel workbooks.


arrow blue right bubbleRelated Articles


Kutools for Outlook - Brings 100 Advanced Features to Outlook, and Make Work Much Easier!

  • Auto CC/BCC by rules when sending email; Auto Forward Multiple Emails by custom; Auto Reply without exchange server, and more automatic features...
  • BCC Warning - show message when you try to reply all if your mail address is in the BCC list; Remind When Missing Attachments, and more remind features...
  • Reply (All) With All Attachments in the mail conversation; Reply Many Emails in seconds; Auto Add Greeting when reply; Add Date into subject...
  • Attachment Tools: Manage All Attachments in All Mails, Auto Detach, Compress All, Rename All, Save All... Quick Report, Count Selected Mails...
  • Powerful Junk Emails by custom; Remove Duplicate Mails and Contacts... Enable you to do smarter, faster and better in Outlook.
shot kutools outlook kutools tab 1180x121
shot kutools outlook kutools plus tab 1180x121
 
Say something here...
symbols left.
You are guest
or post as a guest, but your post won't be published automatically.
Loading comment... The comment will be refreshed after 00:00.
  • To post as a guest, your comment is unpublished.
    saliu2512 · 3 months ago
    I run this macro but keep getting compile error:

    User=defined type not defined

    On line 62 " Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder "

    I have already specified the path as follows:

    ExportToExcel "C:\Users\kudus\Documents\MailExportTest\f1\A.xlsx", "myname@mydomain.com\Inbox\Black Hat Webcast"
    ExportToExcel "C:\Users\\Documekudus\Documents\MailExportTest\f2\B.xlsx", "myname@mydomain.com\Inbox\CPD\Kaplan Training"

    I'm using Outlook 2016 in case that's needed
    • To post as a guest, your comment is unpublished.
      SALIU MAAMA · 3 months ago
      I fixed it. From the visual basic window, go to Tools Reference - and the box for "Microsoft Outlook 16.0 Object Library"


  • To post as a guest, your comment is unpublished.
    JG Tiger · 1 years ago
    Hi,
    I just ran this Macro which works fine.
    I understand that in the expressions
    excWks.Cells(intRow, 1) = olkMsg.Subject
    excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
    excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)

    the olkMsg.* and GetSMTPAddress(olkMsg, intVersion) extract stuff from Outlook.

    What is the argument to use to get the Address the mail was sent to?

    When Using the Export Wizard of Outlook, it is possible to export this address, so I assume it would be possible to do it through this Macro (with some modification).
    Can somebody help?

    Regards
  • To post as a guest, your comment is unpublished.
    danesteatite@gmail.com · 1 years ago
    Hi, Hopefully someone can help me out here, I have virtually no knowledge of VB but have managed to get this script working for me so far.

    However I have around 1500 folders and subfolders under my inbox in total and I would really like a simple script to export all of the email address that I have sent to with the subject line and date on separate columns in Excel.

    I have searched for days, and tried many different sites but cannot get any code to work other than this one.


    Is what I am asking for even possible? If so is there anyone out there kind and clever enough to help me out whit the script I need?
    I presume it has something to do with this part:


    Sub ExportMain()
    ExportToExcel "destination_folder_path\A.xlsx", "your_email_accouny\folder\subfolder_1"
    ExportToExcel "destination_folder_path\B.xlsx", "your_email_accouny\folder\subfolder_2"
    MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
    End Sub


    Thanks in advanced
  • To post as a guest, your comment is unpublished.
    msroumi@gmail.com · 3 years ago
    hello dear, every thing working well many thanks but the body is not exported, how can i export email body too, the excel file has just (Subject, Received, and Sender), if you can update me with it will solve a huge matter in my business many thanks again
    • To post as a guest, your comment is unpublished.
      John · 2 years ago
      In the ExporttoExcel sub you can add the body

      'Write Excel Column Headers
      With excWks
      .Cells(1, 1) = "Subject"
      .Cells(1, 2) = "Received"
      .Cells(1, 3) = "Sender"
      .Cells(1, 4) = "Body"
      End With
      intRow = 2
      For Each olkMsg In olkFld.Items
      'Only export messages, not receipts or appointment requests, etc.
      If olkMsg.Class = olMail Then
      'Add a row for each field in the message you want to export
      excWks.Cells(intRow, 1) = olkMsg.Subject
      excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
      excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
      excWks.Cells(intRow, 4) = olkMsg.Body
      intRow = intRow + 1
    • To post as a guest, your comment is unpublished.
      kellytte · 3 years ago
      Hi Montaser,
      The VBA script runs based on Outlook’s Export feature which doesn’t support exporting message content when bulk exporting emails from a mail folder. Therefore, this VBA script cannot export message content too.
      • To post as a guest, your comment is unpublished.
        Joey Tribbiani · 1 months ago
        this works great, but is there a way to add the info for not just the 4 fields above but all that Outlook export to PST give? 
        Subject    Body    From: (Name)    From: (Address)    From: (Type)    To: (Name)    To: (Address)    To: (Type)    CC: (Name)    CC: (Address)    CC: (Type)    BCC: (Name)    BCC: (Address)    BCC: (Type)    Billing Information    Categories    Importance    Mileage    Sensitivity

        I tried adding "Importance" and it works, but I would appreciate if someone could provide the code for the other fields. thank you!!

        With excWks
        .Cells(1, 1) = "Subject"
        .Cells(1, 2) = "Received"
        .Cells(1, 3) = "Sender"
        .Cells(1, 4) = "Body"
        .Cells(1, 5) = "Importance"
        End With
        intRow = 2
        For Each olkMsg In olkFld.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
        'Add a row for each field in the message you want to export
        excWks.Cells(intRow, 1) = olkMsg.Subject
        excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
        excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
        excWks.Cells(intRow, 4) = olkMsg.Body
        excWks.Cells(intRow, 5) = olkMsg.Importance
        • To post as a guest, your comment is unpublished.
          Amanda Lee · 20 days ago
          Hi, please check the code below to your needs:

          Const MACRO_NAME = "Export Outlook Folders to Excel"

          Sub ExportMain()

          ExportToExcel "destination_folder_path\A.xlsx", "your_email_accouny\folder\subfolder_1"

          ExportToExcel "destination_folder_path\B.xlsx", "your_email_accouny\folder\subfolder_2"

          MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME

          End Sub

          Sub ExportToExcel(strFilename As String, strFolderPath As String)

          Dim olkMsg As Object

          Dim olkFld As Object

          Dim excApp As Object

          Dim excWkb As Object

          Dim excWks As Object

          Dim intRow As Integer

          Dim intVersion As Integer

          If strFilename <> "" Then

          If strFolderPath <> "" Then

          Set olkFld = OpenOutlookFolder(strFolderPath)

          If TypeName(olkFld) <> "Nothing" Then

          intVersion = GetOutlookVersion()

          Set excApp = CreateObject("Excel.Application")

          Set excWkb = excApp.Workbooks.Add()

          Set excWks = excWkb.ActiveSheet

          'Write Excel Column Headers

          With excWks

          .Cells(1, 1) = "Subject"

          .Cells(1, 2) = "Body"

          .Cells(1, 3) = "Received"

          .Cells(1, 4) = "From: (Name)"

          .Cells(1, 5) = "From: (Address)"

          .Cells(1, 6) = "From: (Type)"

          .Cells(1, 7) = "To: (Name)"

          .Cells(1, 8) = "To: (Address)"

          .Cells(1, 9) = "To: (Type)"

          .Cells(1, 10) = "CC: (Name)"

          .Cells(1, 11) = "CC: (Address)"

          .Cells(1, 12) = "CC: (Type)"

          .Cells(1, 13) = "BCC: (Name)"

          .Cells(1, 14) = "BCC: (Address)"

          .Cells(1, 15) = "BCC: (Type)"

          .Cells(1, 16) = "Billing Information"

          .Cells(1, 17) = "Categories"

          .Cells(1, 18) = "Importance"

          .Cells(1, 19) = "Mileage"

          .Cells(1, 20) = "Sensitivity"

          End With

          intRow = 2

          For Each olkMsg In olkFld.Items

          'Only export messages, not receipts or appointment requests, etc.

          If olkMsg.Class = olMail Then

          'Add a row for each field in the message you want to export

          excWks.Cells(intRow, 1) = olkMsg.Subject

          excWks.Cells(intRow, 2) = olkMsg.Body

          excWks.Cells(intRow, 3) = olkMsg.ReceivedTime

          excWks.Cells(intRow, 4) = olkMsg.SenderName

          excWks.Cells(intRow, 5) = GetAddress(olkMsg.Sender, intVersion)

          excWks.Cells(intRow, 6) = olkMsg.Sender.Type

          excWks.Cells(intRow, 7) = GetRecipientsName(olkMsg, 1, 1, intVersion)

          excWks.Cells(intRow, 8) = GetRecipientsName(olkMsg, 1, 2, intVersion)

          excWks.Cells(intRow, 9) = GetRecipientsName(olkMsg, 1, 3, intVersion)

          excWks.Cells(intRow, 10) = GetRecipientsName(olkMsg, 2, 1, intVersion)

          excWks.Cells(intRow, 11) = GetRecipientsName(olkMsg, 2, 2, intVersion)

          excWks.Cells(intRow, 12) = GetRecipientsName(olkMsg, 2, 3, intVersion)

          excWks.Cells(intRow, 13) = GetRecipientsName(olkMsg, 3, 1, intVersion)

          excWks.Cells(intRow, 14) = GetRecipientsName(olkMsg, 3, 2, intVersion)

          excWks.Cells(intRow, 15) = GetRecipientsName(olkMsg, 3, 3, intVersion)

          excWks.Cells(intRow, 16) = olkMsg.BillingInformation

          excWks.Cells(intRow, 17) = olkMsg.Categories

          excWks.Cells(intRow, 18) = olkMsg.Importance

          excWks.Cells(intRow, 19) = olkMsg.Mileage

          excWks.Cells(intRow, 20) = olkMsg.Sensitivity

          intRow = intRow + 1

          End If

          Next

          Set olkMsg = Nothing

          excWkb.SaveAs strFilename

          excWkb.Close

          Else

          MsgBox "The folder '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME

          End If

          Else

          MsgBox "The folder path was empty.", vbCritical + vbOKOnly, MACRO_NAME

          End If

          Else

          MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME

          End If



          Set olkMsg = Nothing

          Set olkFld = Nothing

          Set excWks = Nothing

          Set excWkb = Nothing

          Set excApp = Nothing

          End Sub



          Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder

          Dim arrFolders As Variant

          Dim varFolder As Variant

          Dim bolBeyondRoot As Boolean

          On Error Resume Next

          If strFolderPath = "" Then

          Set OpenOutlookFolder = Nothing

          Else

          Do While Left(strFolderPath, 1) = "\"

          strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)

          Loop

          arrFolders = Split(strFolderPath, "\")

          For Each varFolder In arrFolders

          Select Case bolBeyondRoot

          Case False

          Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)

          bolBeyondRoot = True

          Case True

          Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)

          End Select

          If Err.Number <> 0 Then

          Set OpenOutlookFolder = Nothing

          Exit For

          End If

          Next

          End If

          On Error GoTo 0

          End Function



          Function GetOutlookVersion() As Integer

          Dim arrVer As Variant

          arrVer = Split(Outlook.Version, ".")

          GetOutlookVersion = arrVer(0)

          End Function



          Function SMTPEX(Entry As AddressEntry) As String

          Dim olkPA As Outlook.PropertyAccessor

          On Error Resume Next

          Set olkPA = Entry.PropertyAccessor

          SMTPEX = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")

          On Error GoTo 0

          Set olkPA = Nothing

          End Function



          Function GetAddress(Entry As AddressEntry, intOutlookVersion As Integer) As String

          Dim olkEnt As Object

          On Error Resume Next

          Select Case intOutlookVersion

          Case Is < 14

          If Entry.Type = "EX" Then

          GetAddress = SMTPEX(Entry)

          Else

          GetAddress = Entry.Address

          End If

          Case Else

          If Entry.AddressEntryUserType = olExchangeUserAddressEntry Then

          Set olkEnt = Entry.GetExchangeUser

          GetAddress = olkEnt.PrimarySmtpAddress

          Else

          GetAddress = Entry.Address

          End If

          End Select

          On Error GoTo 0

          Set olkEnt = Nothing

          End Function



          Function GetRecipientsName(Item As MailItem, rcpType As Integer, Ret As Integer, intOutlookVersion As Integer) As String

          Dim xRcp As Recipient

          Dim xNames As String

          xNames = ""

          For Each xRcp In Item.Recipients

          If xRcp.Type = rcpType Then

          If Ret = 1 Then

          If xNames = "" Then

          xNames = xRcp.Name

          Else

          xNames = xNames & "; " & xRcp.Name

          End If

          ElseIf Ret = 2 Then

          If xNames = "" Then

          xNames = GetAddress(xRcp.AddressEntry, intOutlookVersion)

          Else

          xNames = xNames & "; " & GetAddress(xRcp.AddressEntry, intOutlookVersion)

          End If

          ElseIf Ret = 3 Then

          If xNames = "" Then

          xNames = xRcp.AddressEntry.Type

          Else

          xNames = xNames & "; " & xRcp.AddressEntry.Type

          End If

          End If

          ElseIf xRcp.Type = rcpType Then

          If Ret = 1 Then

          If xNames = "" Then

          xNames = xRcp.Name

          Else

          xNames = xNames & "; " & xRcp.Name

          End If

          ElseIf Ret = 2 Then

          If xNames = "" Then

          xNames = GetAddress(xRcp.AddressEntry, intOutlookVersion)

          Else

          xNames = xNames & "; " & GetAddress(xRcp.AddressEntry, intOutlookVersion)

          End If

          ElseIf Ret = 3 Then

          If xNames = "" Then

          xNames = xRcp.AddressEntry.Type

          Else

          xNames = xNames & "; " & xRcp.AddressEntry.Type

          End If

          End If

          ElseIf xRcp.Type = rcpType Then

          If Ret = 1 Then

          If xNames = "" Then

          xNames = xRcp.Name

          Else

          xNames = xNames & "; " & xRcp.Name

          End If

          ElseIf Ret = 2 Then

          If xNames = "" Then

          xNames = GetAddress(xRcp.AddressEntry, intOutlookVersion)

          Else

          xNames = xNames & "; " & GetAddress(xRcp.AddressEntry, intOutlookVersion)

          End If

          ElseIf Ret = 3 Then

          If xNames = "" Then

          xNames = xRcp.AddressEntry.Type

          Else

          xNames = xNames & "; " & xRcp.AddressEntry.Type

          End If

          End If

          End If

          Next

          GetRecipientsName = xNames

          End Function




          Hope this works for you.

          Amanda
  • To post as a guest, your comment is unpublished.
    ClickMonster · 4 years ago
    How do I get this to automatically recurse into subfolders?