VBA - Copy outlook table and subject to excel

rniculae

New Member
Joined
Apr 9, 2013
Messages
41
Hello

I am struggling with copying tables from outlook emails to excel file and adding the subject on the left column for all the rows in that table. Tried to have a macro in Outlook but then I couldn't get the subject into the same excel file. Can you please help me out with a code to do that?

Here's my code in Outlook which gets the table to an excel file but I don't know how add the subject of the email for all the lines of the table then loop to the next email and do the same.

Code:
Sub ExportTablesinEmailtoExcel()    Dim objMail As Outlook.MailItem
    Dim objWordDocument As Word.Document
    Dim objTable As Word.Table
    Dim lTableCount As Long
    Dim objExcelApp As Excel.Application
    Dim objExcelWorkbook As Excel.Workbook
    Dim objExcelWorksheet As Excel.Worksheet
    Dim i As Long
 
    'Create a new excel workbook
    Set objExcelApp = CreateObject("Excel.Application")
    Set objExcelWorkbook = objExcelApp.Workbooks.Add
    objExcelApp.Visible = True
 
    'Get the table(s) in the selected email
    Set objMail = Outlook.Application.ActiveExplorer.Selection.Item(1)
    Set objWordDocument = objMail.GetInspector.WordEditor
    lTableCount = objWordDocument.Tables.Count
 
 
    If lTableCount > 1 Then
       'If there is more than one table
       'Copy each table into separate worksheet
       For i = 1 To lTableCount
           Set objTable = objWordDocument.Tables(i)
           objTable.Range.Copy
 
           Set objExcelWorksheet = objExcelWorkbook.Sheets(i)
           objExcelWorksheet.Paste
           objExcelWorksheet.Columns.AutoFit
       Next
    Else
      'If there is only one table
      'Just copy it into the first worksheet
      Set objTable = objWordDocument.Tables(1)
      objTable.Range.Copy
 
      Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
      objExcelWorksheet.Paste
      objExcelWorksheet.Columns.AutoFit
    End If
End Sub


Sub SaveEmailTablestoExcel()
Dim Item As MailItem, x%
Dim r As Object  'As Word.Range
Dim doc As Object 'As Word.Document
Dim iRow As Long 'row index
Dim xlApp As Object, xlWB As Object
Dim xlSheet As Object
Dim strPath As String
Dim bXStarted As Boolean
'Dim myInspector As Outlook.MailItem
Dim enviro As String
enviro = "C:\test"
'the path of the workbook
 strPath = enviro & "Book1.xlsx"
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
     'Open the workbook to input the data
     Set xlWB = xlApp.Workbooks.Open(strPath)
' Get sheet by name
     Set xlSheet = xlWB.Sheets("Sheet1")




xlApp.Visible = True


For Each Item In Application.ActiveExplorer.Selection
Set doc = Item.GetInspector.WordEditor


     x = doc.Tables.Count
     Set r = doc.Tables(x)
     'y = doc.Subject.Copy  this doesn't work
     


     For iRow = 2 To r.Rows.Count
         r.Rows(iRow).Range.Copy


       xlSheet.Paste
       xlSheet.Range(xlSheet.Rows.Count, 2).End.Offset(-1, 1).Select
        'xlSheet.Selection.Value = y
       xlSheet.Cells(xlSheet.Rows.Count, 1).End(3).Offset(1).Select
       
    
    Next
Next
xlWB.Save


' close workbook
'xlWB.Close 1
'If bXStarted Then
'    xlApp.Quit
'End If


End Sub
Thanks,
Razvan
 

Some videos you may like

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

rniculae

New Member
Joined
Apr 9, 2013
Messages
41
Hello, I've posted a sample of what I would like to get.

Can anyone at least say if this is possible?

Thanks a lot!

Code:
[TABLE="width: 712"]
<tbody>[TR]
[TD]Subject[/TD]
[TD]Table Header 1[/TD]
[TD]Table Header 2[/TD]
[TD]Table Header 3[/TD]
[TD]Table Header 4[/TD]
[TD]Table Header 5[/TD]
[/TR]
[TR]
[TD]Subject email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[/TR]
[TR]
[TD]Subject email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[/TR]
[TR]
[TD]Subject email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[/TR]
[TR]
[TD]Subject email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[TD]Table data email 1[/TD]
[/TR]
[TR]
[TD]Subject email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[/TR]
[TR]
[TD]Subject email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[/TR]
[TR]
[TD]Subject email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[/TR]
[TR]
[TD]Subject email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[/TR]
[TR]
[TD]Subject email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[/TR]
[TR]
[TD]Subject email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[/TR]
[TR]
[TD]Subject email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[/TR]
[TR]
[TD]Subject email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[TD]Table data email 2[/TD]
[/TR]
</tbody>[/TABLE]
 

rniculae

New Member
Joined
Apr 9, 2013
Messages
41
Found the solution, I've added this line after next y and it adds to the next column to the right.

Code:
destCell.Offset(x, y).Value = Mid(oMail.Subject, InStr(oMail.Subject, "PO:") + 3, 10)
Thanks!
R
 

Watch MrExcel Video

Forum statistics

Threads
1,101,904
Messages
5,483,646
Members
407,399
Latest member
Rakeforms

This Week's Hot Topics

  • Finding issue in If elseif else with For each Loop
    Finding issue in If elseif else with For each Loop I have tried this below code but i'm getting in Y column filled with W005. Colud you please...
  • MsgBox Error
    Hi Guys, I have the below error show up when i try and run my macro in File1 but works fine if i copy and paste the same code into file2. [ATTACH...
  • CELL FORMAT - IF CONDITION
    My Cell Format is [B]""0.00" Cr". [/B]But in the cell, it is showing 123.00 for editing. (123 is entry figure). (Data imported from other...
  • Show numbers nearly the same
    Is this possible. I have a number that can change very time eg 0.00001234 Then I have a lot of numbers 0.0000001, 0.0000002, 0.00000004...
  • Please i need your help to create formula
    I need a formula in cell B8 to do this >>if b1=1 then multiply ( cell b8) by 10% ,if b1=2 multiply by 20%,if=3 multiply by 30%. Thank you in...
  • Got error while adding column and filter
    Got error while adding column and filter In column Z has some like "Success" and "Error". I want to add column in AA if the Z cell value is...
Top