VBA Export e-mail body in two different cells-CodePudding

I´m developing a macro that exports e-mails 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.

The inconvenience that I am having at the moment is due to the 32767 characters limit that excel has in a cell and as some emails are large, the body is not being fully exported, which causes I am not to be able to search for the data to fill out the rows because the data is incomplete

Is there a way to export the body in two rows instead of one to avoid the excel limitation? Or any other suggestions to accomplish this process are appreciated. I´m still learning about macro development.

My apologies if my code is not good enough

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

Thanks,

CodePudding user response：

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)