Retrieving Tables from outlook to excel

[Davefin]

@Diane Poremsky ,
You were able to help me on another topic, Which again thanks. Now I've come up with another project I'd like to achieve. I get several emails a day (as included here for samples) that I would like to extract to excel. from there I can manipulate the data to my needs. I've tried to mix and match sample codes from various sites only to get errors or results that are unwanted. There where some close results but not what I was looking for. What I'm looking for is to grab the table data (as highlighted in the sample) and dump it in the same work book and sheet as new emails come in. I know I can assign a rule to run it as I get those emails.
I tried to upload the email but I guess its not allowed so here is a snippet of a sample email I get.
Thanks in advanced
Dave-

 

[Diane Poremsky]

Typically, you'd use regex or instr/mif functions to get the values and send them over to excel... for the table, i'm undecided if using an array would be easier or just trying to copy the table and paste it. Is the message always identical (so the code can find table 2, copy rows 2 - x)?

 

[Diane Poremsky]

The macro that is marked as the answer at Copy a table from body of an email to Excel spreadsheet should get you close. If you need the last table, then change
For x = 1 To doc.tables.Count
to
x = doc.tables.Count

and remove the last Next

it's going to pick up the header as written, but should work good otherwise, especially as long as no fields are merged. (I'm checking on ways to skip the header row and use range)

As written, it works on selected messages - if you want to use it in a rule, it can be tweaked.

 

[Diane Poremsky]

This code should work with a run a script rule -

Sub dd(Item As Outlook.MailItem)
Dim r As Object  'As Word.Range
Dim doc As Object 'As Word.Document
Dim iRow As Long 'row index
Dim xlApp As Object, wkb As Object
Set xlApp = CreateObject("Excel.Application")
Set wkb = xlApp.Workbooks.Add
xlApp.Visible = True

Dim wks As Object
Set wks = wkb.Sheets(1)

Set doc = Item.GetInspector.WordEditor
 '   For x = 1 To doc.Tables.Count
     x = doc.Tables.Count
     Set r = doc.Tables(x)
' get rows 2 - end:
     For iRow = 2 To r.Rows.Count
        r.Rows(iRow).Range.Copy
' to get all rows in the table
     ' r.Range.Copy
       wks.Paste
       wks.Cells(wks.Rows.Count, 1).End(3).Offset(1).Select
    Next
End Sub

 

[Davefin]

Thanks for the reply i'll put it to the test and give you an update. Sometimes the email will contain more than one table. I think the most I've seen so far is 4 of em with the same header

 

[Davefin]

So the link you pointed out I have seen and that one was the closest to what I wanted to achieve. The problem with that one is that
1: it creates a new workbook every time it runs
2: I really wanted to avoid copying the first table.:

Here is a little more info on these emails too if this helps
Usually the first email doesn't have any data in the tables because nothing has occurred.
so it looks like this:

as reports come in it looks like the above. The first table is always just that table the second table can go anywhere from 1 to 5 or more but the layout is always the same

 

[Diane Poremsky]

it creates a new workbook every time it runs

yeah, that code does. meant to post this link last night - Copy data from Outlook email tables to Excel - I tweaked the macro. It gets either the last (or could get any specific table by index #) or all - changing the 'all' code to get 2 to count should get 2 - last:
For x = 2 To doc.Tables.Count

my need an 'on error resume next' if the blank table errors, or
if r.Rows.Count > 1 then
For iRow = 2 To r.Rows.Count
' paste into sheet
next
end if

 

[Davefin]

or all - changing the 'all' code to get 2 to count should get 2 - last:

when changing to get all i get this:

I shrank the cells to fit on one page.
Now when I change: For x = 1 To doc.Tables.Count
to: For x = 2 To doc.Tables.Count
I get rid of the junk rows 1-12. If I change the 2 to a 3 i get rid of the unwanted 13-29 but loose the wanted table directly underneath. The rest of the tables are pasted tho. I did notice that there are some merged cells on the email. I would post a sample email but this site wont let me post a .mgs file.
I tried to change the xlsheet.paste to xlsheet.PasteSpecial xlPasteValues
but when it ran it looked as if those were pasted pictures. the formatting isn't really that important because i'll will be removing duplicates and then pasting the values to another document anyway.

 

[Diane Poremsky]

Yeah, merged cells will be a problem. Reading the rows eliminates the merged cell problems, but i'm not sure if it will work with multiple tables. Will check.

zip the email then you should be able to upload it.

 

[Davefin]

zip the email

Here are the sample emails. I've replaced any sensitive info with bla text. Thanks again.

 

[Davefin]

@Diane Poremsky any new info?

 

[Diane Poremsky]

no, sorry - i started looking at it and ran into problems and set it aside. will take another look.

 

[Diane Poremsky]

below is the code i have so far to get just the last 2 tables (getting all tables works, but it also includes the body text) - i'm trying to get just the table with the RS Type in the first cell but it only gets the last - the debug.print results shows why - there are 3 tables. First begins with the characters 'Greetin'. Table 2 begins with 'Repeat'. Only table 3 meeting the condition of the If statement.

1 tables
Greetin Trimmed
2 tables
Repeat Trimmed
3 tables
RS Type Trimmed

i honestly don't know how to get around it - i think its because there isn't a space between the first 2 tables, but cant be 100% sure.

This is what outlook sees as table 1 and 2:

Sub RunScript()
Dim objApp As Outlook.Application
Dim objItem As MailItem
Set objApp = Application
Set objItem = Application.ActiveExplorer.Selection.Item(1)

'macro name you want to run goes here
dd objItem

End Sub


Sub dd(Item As Outlook.MailItem)
Dim r As Object  'As Word.Range
Dim doc As Object 'As Word.Document
Dim iRow As Long 'row index
Dim xlApp As excel.Application 'Object
Dim wkb As excel.Workbook ' Object
Dim wks As excel.Worksheet ' Object
Set xlApp = CreateObject("Excel.Application")
Set wkb = xlApp.Workbooks.Add
xlApp.Visible = True

Set wks = wkb.Sheets(1)

Set doc = Item.GetInspector.WordEditor
    For x = 1 To doc.Tables.Count
     Set r = doc.Tables(x)
     Debug.Print x, "tables"
' get rows 2 - end:
'For iRow = 2 To r.Rows.Count
StrCellText = r.Cell(1, 1).Range.Text
StrCellText = Replace(StrCellText, vbCr, "")
StrCellText = Replace(StrCellText, Chr(7), "")

On Error Resume Next
Debug.Print Trim(Left(StrCellText, 7)), "Trimmed"
If Trim(Left(StrCellText, 7)) = "RS Type" Then

' to get all rows in the table
      r.Range.Copy
    wks.Cells(wks.Rows.Count, 1).End(xlUp).PasteSpecial xlPasteValues
End If
   'Next iRow
   Next x
End Sub

 

[Davefin]

Was I supposed to change something?
also I wanted to thank you again for your time that you have taken to look at this.

 

[Diane Poremsky]

You need to set a reference to Excel Object library in Tools, References. if you use as object (which i commented out), you don't need to do this but some bits of the object model aren't available.