vba copy email body to excel as table

Question

Hi I have the following code which successfully loops through my folder and pulls the email I want and copies the body (which is in table format) into excel. however, when I paste it In, the entire body gets pasted in cell A1 when it should fill the range A1:K92 as it would if I manually copied and pasted it. is there any way to use vba to paste it in the correct range? Thanks!

Sub GetFXEmail()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMi As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set Fldr = Fldr.Folders("MyFolder")
Set inboxItems = Fldr.Items

pnldate = Format((Date - 1), "mm/dd/yyyy")

Set inboxItems = Fldr.Items
inboxItems.Sort "[ReceivedTime]", True
For i = 1 To Fldr.Items.Count Step 1
    Set olMi = Fldr.Items(i)
        If Format(olMi.ReceivedTime, "mm/dd/yyyy") = pnldate Then
            Debug.Print olMi.ReceivedTime
            Debug.Print olMi.Subject
            If InStr(1, olMi.Subject, "Breakdown") > 0 Then
                Sheets("Sheet1").Range("A1") = olMi.Body
                GoTo AllDone
            End If
        End If
Next i

AllDone:
End Sub

Answer 1

If you only have 1 table in the email and it's recognized as an actual table this code (to be placed inside the first If block) will work (and has been tested). You can modify the parts to suit your exact needs, if need be.

Also note, it requires an Reference to the Microsoft Word Object Library (as you have already the Outlook Object Library).

If Format(olMi.ReceivedTime, "mm/dd/yyyy") = pnldate Then

    With olMi

        Debug.Print .ReceivedTime
        Debug.Print .Subject

        Dim olInsp As Outlook.Inspector
        Set olInsp = .GetInspector

        Dim wdDoc As Word.Document
        Set wdDoc = olInsp.WordEditor

        Dim tb As Word.Table
        For Each tb In wdDoc.Tables 'assumes only 1 table
            Dim y as Long, x as Long
            For y = 0 To tb.Rows.Count
                For x = 0 To tb.Columns.Count
                    Sheets("Sheet1").Range("A1").Offset(y, x).Value = tb.Cell(y, x).Range.Text
                Next
            Next
        Next

    End With

    GoTo AllDone

End If