title: How to export e-mail body in two different cells?
body: <p>I want to export e-mail data from a specific folder by a range of dates.</p>
  <p>The macro exports the received date and the body of the email.</p>
  <p>The objective is to search for certain data that comes from the extracted body and show them in other rows.</p>
  <p>Due to the 32767 character limit that Excel has in a cell, the bodies of some emails are not being fully exported.</p>
  <p>Is there a way to export the body in two rows instead of one to avoid the Excel limitation?</p>
  <p>Other suggestions to accomplish this process are appreciated.</p>
  <pre class="lang-vb prettyprint-override"><code>Sub ImportEmails()
  
  Dim OutlookApp As Outlook.Application
  Dim OutlookNamespace As Outlook.Namespace
  Dim IFolder As Outlook.MAPIFolder
  Dim OutlookMail As Variant
  Dim i As Integer
  Dim wb As Workbook
  Dim ws As Worksheet
  Dim rng As Range
  
  Set OutlookApp = New Outlook.Application
  'Outlook connection
  Set OutlookNamespace = OutlookApp.GetNamespace(&quot;MAPI&quot;)
  Set wb = ThisWorkbook
  'Select the folder to export emails, depending on the user´s folder name you must change it
  Set IFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders(&quot;Test&quot;)
  Set ws = wb.Sheets(&quot;Imported&quot;)
  i = 0
  
  Application.ScreenUpdating = False
  
  ws.Cells.Clear
  'Create headers
  ws.Range(&quot;A1&quot;).Value = &quot;Date Time&quot;
  ws.Range(&quot;B1&quot;).Value = &quot;Body&quot;
  
  'Condition to select the today date in case of blank and export the emails
  If IsEmpty(Range(&quot;end_date&quot;).Value) = True Then
      Range(&quot;end_date&quot;).Value = &quot;=today()&quot;
  End If
  
  'Exporting proccedure
  For Each OutlookMail In IFolder.Items
      'Date validation
      If DateValue(OutlookMail.ReceivedTime) &gt;= DateValue(Range(&quot;start_date&quot;)) And DateValue(OutlookMail.ReceivedTime) &lt;= DateValue(Range(&quot;end_date&quot;)) Then
          'Fill the worksheet cells with the emails
          ws.Range(&quot;A2&quot;).Offset(i, 0).Value = OutlookMail.ReceivedTime
          ws.Range(&quot;B2&quot;).Offset(i, 0).Value = OutlookMail.Body
      
          i = i + 1
      End If
  Next OutlookMail
  Application.ScreenUpdating = True
  
  Set IFolder = Nothing
  Set OutlookNamespace = Nothing
  Set OutlookApp = Nothing
  
  LRimpr = LastRow(ws)
  Set rng = ws.Range(&quot;A2:B&quot; &amp; LRimpr)
   
  'Sort the columns by newest to oldest using the worksheet last row
  With rng
      .Sort Key1:=.Cells(1), Order1:=xlDescending, _
        Orientation:=xlTopToBottom, Header:=xlNo
  End With
  
  MsgBox &quot;Emails are successfully imported&quot;, vbInformation, &quot;Import complete&quot;
  ws.Activate
  End Sub
  </code></pre>