Download Outlook email content to excel - excel

Question

I need to download the all the emails in a particular to excel. I found a code which works pretty close, but the mail content are not pasting in a single cell.
And I would also like to have only particular details of the body. Can some one help me in modifying the below code for..
*updated:
I would need only part of mail content (as marked below) to be downloaded to excel.
Could you please help me with this.
Excel VBA Code:
Sub GetMail()
Dim olApp As Object
Dim olFolder As Object
Dim olMailItem As Object
Dim strTo As String
Dim strFrom As String
Dim dateSent As Variant
Dim dateReceived As Variant
Dim strSubject As String
Dim spBody As Variant
Dim loopControl As Variant
Dim mailCount As Long
Dim totalItems As Long
'-------------------------------------------------------------
'//Turn off screen updating
Application.ScreenUpdating = False
'//Setup headers for information
Range("A1:F1").Value = Array("To", "From", "Subject", "Body", "Sent (from Sender)", "Received (by Recipient)")
'//Format columns E and F to
Columns("E:F").EntireColumn.NumberFormat = "DD/MM/YYYY HH:MM:SS"
'//Create instance of Outlook
Set olApp = CreateObject("Outlook.Application")
'//Select folder to extract mail from
Set olFolder = olApp.GetNamespace("MAPI").PickFolder
'//Get count of mail items
totalItems = olFolder.Items.Count
mailCount = 0
'//Loop through mail items in folder
For Each loopControl In olFolder.Items
'//If loopControl is a mail item then continue
If TypeName(loopControl) = "MailItem" Then
'//Increase mailCount
mailCount = mailCount + 1
'//Inform user of item count in status bar
Application.StatusBar = "Reading email no. " & mailCount & " of " & totalItems
'//Get mail item
Set olMailItem = loopControl
'//Get Details
With olMailItem
strTo = .To
'//If strTo begins with "=" then place an apostrophe in front to denote text format
If Left(strTo, 1) = "=" Then strTo = "'" & strTo
strFrom = .Sender
'//If sender displays name only, show name followed by email address e.g.(Bloggs, Joe < j.bloggs#mail.com >)
If InStr(1, strFrom, "#") < 1 Then strFrom = strFrom & " - < " & .SenderEmailAddress & " >"
dateSent = .SentOn
dateReceived = .ReceivedTime
strSubject = .Subject
spBody = Split(.Body, vbCrLf)
End With
'//Place information into spreadsheet
'//import information starting from last blank row in column A
With Range("C" & Rows.Count).End(xlUp).Offset(1, -2)
.Value = strTo
.Offset(0, 1).Value = strFrom
.Offset(0, 2).Value = strSubject
.Offset(0, 3).Resize(UBound(spBody) + 1, 1).Value = WorksheetFunction.Transpose(spBody)
.Offset(0, 4).Value = dateSent
.Offset(0, 5).Value = dateReceived
End With
'//Release item from memory
Set olMailItem = Nothing
End If
'//Next Item
Next loopControl
'//Release items from memory
Set olFolder = Nothing
Set olApp = Nothing
'//Resume screen updating
Application.ScreenUpdating = False
'//reset status bar
Application.StatusBar = False
'//Inform user that code has finished
MsgBox mailCount & " messages copied successfully.", vbInformation, "Complete"
End Sub

Answer 1

"but the mail content are not pasting in a single cell"
change:
Dim spBody As Variant
to:
Dim spBody As String
then change:
spBody = Split(.body, vbCrLf) '<--| Split() function is "splitting" the mail body into an array with as many elements as vbCrlf occurrences plus one
to:
spBody = .body
and finally change:
.Offset(0, 3).Resize(UBound(spBody) + 1, 1).Value = WorksheetFunction.Transpose(spBody) '<--| Resize() is "widening" the range to write values in to as many rows as 'spBody' array elements
to:
.Offset(0, 3).Value = spBody