VBA Export Outlook emails to Excel

[floggingmolly]

I have a Macro to export emails from Outlook to Excel. The macro works, but the email body many times is too large for a cell in Excel because it can contain data for several different entries. Each entry is divided by a line ********************* like this. Is there any possible way to adjust the macro so it divides the email into separate cells after each divider line represented by ****************? Below is the macro.

Sub GetFromOutlook()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("LEXIS NEXIS")

i = 1

For Each OutlookMail In Folder.Items
    If OutlookMail.ReceivedTime >= Range("From_date").Value Then
        Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
        Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
        Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName
        Range("eMail_text").Offset(i, 0).Value = OutlookMail.Body
        
        i = i + 1
    End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub

 

[DanteAmor]

Check if this works for you:

Sub GetFromOutlook()
  Dim OutlookApp As Outlook.Application
  Dim OutlookNamespace As Namespace
  Dim Folder As MAPIFolder
  Dim OutlookMail As Variant
  Dim i As Long, j As Long
  
  Dim body_text As String
  Dim body_cell As Variant, bc As Variant
  
  Set OutlookApp = New Outlook.Application
  Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
  Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("LEXIS NEXIS")
  
  i = 1
  j = 0
  For Each OutlookMail In Folder.Items
    If OutlookMail.ReceivedTime >= Range("From_date").Value Then
      Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
      Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
      Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName
      
      body_text = OutlookMail.Body
      j = 0
      If InStr(1, body_text, "*") > 0 Then
        body_cell = Split(body_text, "*")
        For Each bc In body_cell
          If bc <> "" Then
            Range("eMail_text").Offset(i, j).Value = bc
            j = j + 1
          End If
        Next
      Else
        Range("eMail_text").Offset(i, 0).Value = body_text
      End If
      
      i = i + 1
    End If
  Next OutlookMail
  
  Set Folder = Nothing
  Set OutlookNamespace = Nothing
  Set OutlookApp = Nothing

End Sub