Copy Paste table data from a .msg file into separate cells in an Excel worksheet using Excel VBA

Question

I have a .msg file in which the body contains data in a tabular form. I am trying to copy this data to Excel and preserve the same tabular form. There are 2 columns and multiple rows in this tabular form.

When I do this manually I get each value in a different cell in Excel.

I have below code.

Private Sub Workbook_Open()
    Dim MyOutlook As Outlook.Application
    Dim Msg As Outlook.MailItem
    Dim x As Namespace
    Dim Row As Integer
    Dim Path As String
    Set MyOutlook = New Outlook.Application
    Set x = MyOutlook.GetNamespace("MAPI")
    Path = "C:\Users\xxx\Downloads\Outlook Import\abc.msg"
    Set Msg = x.OpenSharedItem(Path)

    Sheets("Sheet2").Range("A1") = Msg.Sender
    Sheets("Sheet2").Range("A2") = Msg.CC
    Sheets("Sheet2").Range("A3") = Msg.To
    Sheets("Sheet2").Range("A4") = Msg.SentOn
    Sheets("Sheet2").Range("A5") = Msg.SenderEmailAddress
    Sheets("Sheet2").Range("A6") = Msg.ReceivedByEntryID
    Sheets("Sheet2").Range("A7") = Msg.Subject
    Sheets("Sheet2").Range("A8") = Msg.Body
End Sub

This is copying the whole body and pasting it into one cell ie "A8".

Sheets("Sheet2").Range("A8") = Msg.Body

Answer 1

If I understand your question correctly, you want the email body to be inserted row by row in the document, starting from Range("A8") ?

This works for me:

Private Sub Workbook_Open()
    Dim MyOutlook As Outlook.Application
    Dim Msg As Outlook.MailItem
    Dim x As Namespace
    Dim Row As Integer
    Dim Path As String
    Dim vItem As Variant

    Set MyOutlook = New Outlook.Application
    Set x = MyOutlook.GetNamespace("MAPI")
    Path = "C:\Test\test.msg" ' change path & name of msg file
    Set Msg = x.OpenSharedItem(Path)

    With Sheets("Sheet2")
        .Range("A1") = Msg.Sender
        .Range("A2") = Msg.CC
        .Range("A3") = Msg.To
        .Range("A4") = Msg.SentOn
        .Range("A5") = Msg.SenderEmailAddress
        .Range("A6") = Msg.ReceivedByEntryID
        .Range("A7") = Msg.Subject
        vItem = Split(Msg.Body, Chr(10))
        .Range("A8").Resize(UBound(vItem) - LBound(vItem) + 1, 1) = Application.Transpose(vItem)
    End With
End Sub

Edit #1

This copies the email HTMLbody to the clipboard and pastes it into the document afterwards retaining the column structure:

Private Sub Workbook_Open()
    Dim MyOutlook As Outlook.Application
    Dim Msg As Outlook.MailItem
    Dim x As Namespace
    Dim Row As Integer
    Dim Path As String
    Dim vItem As Variant

    Set MyOutlook = New Outlook.Application
    Set x = MyOutlook.GetNamespace("MAPI")
    Path = "C:\Test\test.msg" ' change path
    Set Msg = x.OpenSharedItem(Path)

    With Sheets("Sheet2")
        .Range("A1") = Msg.Sender
        .Range("A2") = Msg.CC
        .Range("A3") = Msg.To
        .Range("A4") = Msg.SentOn
        .Range("A5") = Msg.SenderEmailAddress
        .Range("A6") = Msg.ReceivedByEntryID
        .Range("A7") = Msg.Subject

        ' requires Microsoft Forms 2 Object Library under Tools/References
        With New MSForms.DataObject
            .SetText Msg.HTMLBody
            .PutInClipboard
        End With

        .Range("A8").PasteSpecial (xlPasteAll) ' change paste type if necessary

    End With

End Sub