CODEWITHSUNDEEP
excelvbaoutlook
Meghan
Meghan

Reputation: 125

vba copy email body to excel as table

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

Upvotes: 3

Views: 2686

Answers (2)

Elbert Villarreal
Elbert Villarreal

Reputation: 1716

Even Scot give you a great answer, I give my answer, may be could help someone else.

This take the string, and create a table, parsing the data, inside the excel, offset 1 column, but this could be fixed just with a .copy. 

Sub convertToTable()
    Dim bigString As String
    Dim i
    Dim lenString
    Dim n
    Dim typeChar
    Dim r
    Dim rng As Range
    Dim lineLen
    Dim a
    Dim tLen
    Dim textR

    bigString = Range("A1").Value 'take the value from A1
    lenString = Len(bigString) 'take the lenght

    Do 'go over the string spliting by the new line character (char10)
        i = i + 1 'just the index
        Range(Cells(i, 1), Cells(i, 1)).Value = Left(bigString, InStr(1, bigString, Chr(10)))
        'important:
        'use the col 1 to put the values in the sheet, here we split just into rows
        'you can change the value of the column as you want
        bigString = Right(bigString, Len(bigString) - InStr(1, bigString, Chr(10)))
        'here adjust the string to the rest of the text
    Loop While i < lenString

    r = Range(Cells(1, 1), Cells(1, 1)).End(xlDown).Row 'same as Range("A1").End
    Set rng = Range(Cells(1, 2), Cells(r, 2)) 'the whole range of data in col A

    a = 1 'here set 1 to use the column B (a = a + 1)
          'if we delete the data there will be a trouble
    For Each i In rng 'for each cell/row in the data range in column A
        tLen = Len(i.Value) 'the lenght
        textR = i.Value 'the text
        Do
            a = a + 1 'the next column...
            Cells(i.Row, a).Value = Left(textR, InStr(1, textR, Chr(32)))
            'Left(textR, InStr(1, textR, Chr(32)))
            'this split the values using the space char (Chr(32)), but you can
            'change it as you need, just find the spliting character
            textR = Right(textR, Len(textR) - InStr(1, textR, Chr(32)))
        Loop While InStr(1, textR, Chr(32)) <> 0
        a = 1
    Next i
End Sub

Upvotes: 0

Scott Holtzman
Scott Holtzman

Reputation: 27239

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

Upvotes: 3

Related Questions