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

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

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,102,642
Messages
5,488,071
Members
407,622
Latest member
plantaddict

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top