Привет, мы экспортируем таблицу из нескольких писем Outlook в один лист Excel. Ниже приведен макрос для копирования таблицы в Excel с помощью правила outlook, которое позволяет макросу запускаться, если письмо получает с определенными c условиями. но каждый раз, когда полученное письмо с условным макросом заменяет содержимое в листе Excel.
, если при получении нового письма необходимо добавить новую строку с содержимым в существующую таблицу.
Таблицы на почте
Public Sub SalvaExcel(item As Outlook.MailItem)
'This macro writes an Outlook email's tables to an Excel workbook
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.Items
Dim olNameSpace As Outlook.NameSpace
Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim olEleColl As MSHTML.IHTMLElementCollection
Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim eRow As Long
Dim i As Long
Dim j As Long
Dim t
Dim posicao As String
'set email to be saved
'Set olApp = Outlook.Application
'Set olNameSpace = Application.GetNamespace("MAPI")
'Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
'Set olItems = olFolder.Items
'olItems.Sort ("[ReceivedTime]")
'the most recent one
'Set olMail = olItems(olItems.Count)
'save Outlook email's html body (tables)
With olHTML
.Body.innerHTML = item.HtmlBody
Set olEleColl = .getElementsByTagName("table")
End With
'set excel file to be opened
FileName = "C:\Users\desktop\desktop_allocation.xlsx"
'create an Excel instance
Set xlApp = Application.CreateObject("Excel.Application")
'in this instance
With xlApp
.Visible = True 'if True, this slows down the macro, but helps during debugging
.ScreenUpdating = False 'if False, this reduces flash and increases speed
'open workbook
Set ExcelWkBk = xlApp.Workbooks.Open(FileName)
'in this workbook
With ExcelWkBk
'in [email] worksheet
With .Worksheets("email")
'which row to start
eRow = 1
posicao = "A" & eRow
'write each table in excel
For Each t In olEleColl
For i = 0 To t.Rows.Length - 1
For j = 0 To t.Rows(i).Cells.Length - 1
'ignore any problems with merged cells etc
On Error Resume Next
.Range(posicao).Offset(i, j).Value = t.Rows(i).Cells(j).innerText
On Error GoTo 0
Next j
Next i
'define from which row the next table will be written
eRow = eRow + t.Rows.Length + 1
posicao = "A" & eRow
Next t
End With
'close Workbook and save changes
.Close SaveChanges:=True
End With
'quit excel
.Quit
End With
Set xlApp = Nothing
Set ExcelWkBk = Nothing
'Set olMail = Nothing
Set olHTML = Nothing
Set olEleColl = Nothing
End Sub