title: Copy data from emails in Outlook Inbox and personal subfolders to Excel through VBA
body: <p>I need to copy the name, subject and received date fields from emails received in my Outlook 2007/2010 inbox, subfolders and public shared folders to Excel 2007/2010.</p>
  
  <p>Also when I export to Excel it should append data every time I run the macro.</p>
  
  <p>This code, which I got online, allows me to pick a folder but not multiple selection. Is there a way to select multiple folders.</p>
  
  <p>Source link to the code: <a href="https://web.archive.org/web/1/http://i.techrepublic%2ecom%2ecom/downlo...k_to_excel.zip" rel="nofollow noreferrer">https://web.archive.org/web/1/http://i.techrepublic%2ecom%2ecom/downlo...k_to_excel.zip</a></p>
  
  <pre class="lang-vb prettyprint-override"><code>Sub ExportToExcel()
  
  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
  
  strSheet = "OutlookItems.xls"
  strPath = "C:\Examples\"
  strSheet = strPath &amp; strSheet
  Debug.Print strSheet
  
  'Select export folder
  Set nms = Application.GetNamespace("MAPI")
  Set fld = nms.PickFolder
  
  'Handle potential errors with Select Folder dialog box.
  If fld Is Nothing Then
  MsgBox "There are no mail messages to export", vbOKOnly, _
  "Error"
  Exit Sub
  ElseIf fld.DefaultItemType &lt;&gt; olMailItem Then
  MsgBox "There are no mail messages to export", vbOKOnly, _
  "Error"
  Exit Sub
  ElseIf fld.Items.Count = 0 Then
  MsgBox "There are no mail messages to export", vbOKOnly, _
  "Error"
  Exit Sub
  End If
  
  '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
  
  '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.To
      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.SentOn
      intColumnCounter = intColumnCounter + 1
      Set rng = wks.Cells(intRowCounter, intColumnCounter)
      rng.Value = msg.ReceivedTime
  Next itm
  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 &amp; " doesn't exist", vbOKOnly, _
        "Error"
  Else
      MsgBox Err.Number &amp; "; 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
  </code></pre>