Great post - Copying all the emails from Outlook inbox plus subfolders to excel.

I also use a similar code to export all outlook emails to excel. However, I've never managed to get around the problem of how to select a specific folder and the Macro with then circle through all the folders and sub-folders within that, exporting my required info to excel.

See my code below. In my case I require the sender name, sender email, message subject, parent folder and date sent on. To get round my lack of knowledge, I have listed all the names of the folders i want the macro to look in into the code.

If any clever folks out there can help me get round this, I'd be very pleased.


Sub ExportInboxToOneSheet()
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object, cnt As Long, i As Long
Dim v As Variant, v1 As Variant

' check spelling - make sure these are the correct folder names

v1 = Array("Bank Details 2011", "Bank Details to Be Checked", "MPower/Gateway Interface Errors Treated by DI 2011", "Gateway MPower Interface Error", "Mpower Test Results", "NO DI ACTION - For Information", "Competence Pilot", "Data Management", "Elements OD", "Holidays OD", "Interface", "MIP", "OLM OD", "Oracle Testing", "Person Type OD", "Procedures / Process", "Proposed Improvements", "Reporting", "Secondary Roles", "Secondments", "Addresses", "Assignment Category", "Competence Increments", "Contract Type", "Cost Centre Costing", "Costing Agency / PAYE", "Costing Staff (incl Core)", "Duplicate Records", "Elements", "Expenses", "Grade Rates", "Grades / Job", "Holidays", "Location", "Mass Updates", "Multiple Assignments", "NI Number", "OLM", "Organisation", "Payroll", "People Group", _
"Proration", "Reason Field", "Record Deletion", "Record Resaves", "Rehire", "Reports", "Reverse Terminations / Terminations", "Salary Basis", "Salary Page Deletion/Amendments", "Start Dates", "Supervisor", "Third Party", "Transfers", "WGOS - Talisman", "Work Pattern OH", "Corrupt Records", "Element Formula`s", "IT Log a Fault / BCR'S", "Oracle Maintenance", "Agency", "Cost Centre", "Element Links", "Grade Rate / Formula / Schedule of Rates/Elements", "Job / Function / Discipline /Grade / Grade Combination", "Lookups / Value Sets / Table Values", "OM OLM", "Organisation / Location", "Testing", "Work Pattern OM", "Overpayments", "Leaver Reports", "Overpayment Reports to HR")


ReDim v(LBound(v1) To UBound(v1))
strSheet = "ExportInboxToOneSheet2.xlsx"
strPath = "G:\BSD\Data Integrity\Data Integrity\Inbox Stats Workings\"
'   strPath = "C:\working\Data\"
strSheet = strPath & strSheet
Debug.Print strSheet
' Search for specified folders
Set nms = Application.GetNamespace("MAPI")
For Each fld In nms.Folders
If InStr(1, fld.Name, "Public", vbTextCompare) = 0 And _
  InStr(1, fld.FolderPath, "Public", vbTextCompare) = 0 Then
'Debug.Print fld.FolderPath, fld.Name
FindFldr fld, v, v1
End If
Next
Set fld = Nothing
cnt = 0
If v(LBound(v)) Is Nothing Then
MsgBox "Folder " & v1(LBound(v)) & " was not found"
cnt = cnt + 1
End If
If v(UBound(v)) Is Nothing Then
MsgBox "Folder " & v1(UBound(v)) & " was not found"
cnt = cnt + 1
End If
If cnt >= 2 Then
MsgBox "Neither folder was found, quitting"
Exit Sub
End If
'  Debug.Print v(i).Name


'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Set fld = nms.PickFolder
cnt = 0
intRowCounter = 1  '<== initialize row counter
For i = LBound(v) To UBound(v)
On Error Resume Next
Set fld = v(i)
On Error GoTo ErrHandler
cnt = cnt + 1
'Set wks = wkb.Sheets(cnt)  ' <=  sheet shouldn't change
'intRowCounter = 1  '<== moved above the loop

wks.Activate
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export for folder: " & v1(i), _
  bOKOnly, "Error"
ElseIf fld.DefaultItemType <> olMailItem Then
 MsgBox "There are no mail messages to export for folder: " & v1(i), _
  bOKOnly, "Error"
 Exit Sub
ElseIf fld.Items.Count = 0 Then
 MsgBox "There are no mail messages to export for folder: " & v1(i), _
  bOKOnly, "Error"
 Exit Sub
End If

'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SenderName
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Parent.Name
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Next itm
intRowCounter = intRowCounter + 2
Next i
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler:
'If Err.Number = 1004 Then
'MsgBox strSheet & " doesn't exist", vbOKOnly, _
'"Error"
'Else
MsgBox Err.Number & "; Description: ", vbOKOnly, _
"Error"
'End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub

Sub FindFldr(fldr As Outlook.MAPIFolder, v As Variant, v1 As Variant)
Dim fldr1 As Outlook.MAPIFolder
If fldr.Folders.Count > 1 Then
For Each fldr1 In fldr.Folders
 If InStr(1, fldr1.Name, "Public", vbTextCompare) = 0 And _
  InStr(1, fldr1.FolderPath, "Public", vbTextCompare) = 0 Then
  'Debug.Print fldr1.FolderPath, fldr1.Name
  For i = LBound(v1) To UBound(v1)
    If InStr(1, fldr1.Name, v1(i), vbTextCompare) <> 0 And Len(fldr1.Name) _
      = Len(v1(i)) Then
        Set v(i) = fldr1
    End If
  Next
  FindFldr fldr1, v, v1
 End If
Next
End If
End Sub