How to export e-mail body in two different cells?

Question

I want to export e-mail data from a specific folder by a range of dates.

The macro exports the received date and the body of the email.

The objective is to search for certain data that comes from the extracted body and show them in other rows.

Due to the 32767 character limit that Excel has in a cell, the bodies of some emails are not being fully exported.

Is there a way to export the body in two rows instead of one to avoid the Excel limitation?

Other suggestions to accomplish this process are appreciated.

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("MAPI")
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("Test")
Set ws = wb.Sheets("Imported")
i = 0

Application.ScreenUpdating = False

ws.Cells.Clear
'Create headers
ws.Range("A1").Value = "Date Time"
ws.Range("B1").Value = "Body"

'Condition to select the today date in case of blank and export the emails
If IsEmpty(Range("end_date").Value) = True Then
    Range("end_date").Value = "=today()"
End If

'Exporting proccedure
For Each OutlookMail In IFolder.Items
    'Date validation
    If DateValue(OutlookMail.ReceivedTime) >= DateValue(Range("start_date")) And DateValue(OutlookMail.ReceivedTime) <= DateValue(Range("end_date")) Then
        'Fill the worksheet cells with the emails
        ws.Range("A2").Offset(i, 0).Value = OutlookMail.ReceivedTime
        ws.Range("B2").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("A2:B" & 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 "Emails are successfully imported", vbInformation, "Import complete"
ws.Activate
End Sub

Answer 1

If you would be happy exporting the email body in multiple cells in a single row then replace your line

ws.Range("B2").Offset(i, 0).Value = OutlookMail.Body

with

Const CHUNK_SIZE As Long = 32000
Dim segment As Long
segment = 0
Do While True
    ws.Range("B2").Offset(i, segment).Value = Mid$(OutlookMail.Body, segment * CHUNK_SIZE + 1, CHUNK_SIZE)
    segment = segment + 1
    If segment * CHUNK_SIZE > Len(OutlookMail.Body) Then Exit Do
Loop

Adjust the value for CHUNK_SIZE to your requirements ... it controls the number of characters that will be put into each cell, with the last cell having the 'remaining' characters (or all the characters if the body has less characters than CHUNK_SIZE)