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.
Thanks,
Razvan
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 SubThanks,
Razvan
