Collate tables from outlook mails into an Excel sheet using Excel VBA

Question

I have an Excel file which will be used as a tool collate tables from mails. One mail will have only one table and one record in it. I need to collate the records in all such tables (from different mails) into One Excel table. I have the following code to do it. This code when run, copies the entire text in body of mail to Excel (So the code works only if the mail has Table with no other text in the body of mail). But I need to copy only the Table present in the mail to Excel. Please help me modify the code to do this. Please note that I do not want to write any code in outlook. Also the copied table is pasted as text. I want them to get pasted in table format. The part of the code which will need modification is shown below.

    Public Sub ExportToExcel1()

Application.ScreenUpdating = False

'Variable declaration

Dim i As Integer
Dim ns As Namespace
Dim Inbox As Outlook.MAPIFolder
Dim item As Object
Dim doClip As MSForms.DataObject
Dim d As String

'Set values for variables

i = 2
d = ActiveSheet.Range("subject").Value

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set doClip = New MSForms.DataObject

'Loop to check mails and pull data

For Each item In Inbox.Items
    If TypeName(item) = "MailItem" And item.Subject = d Then
        doClip.SetText item.Body
        doClip.PutInClipboard
        ActiveSheet.Cells(1, 1).PasteSpecial "Text"

EndSub

Tony Dallimore Tony Dallimore · Accepted Answer · 2014-04-14T17:58:35

There are two mistakes in your code:

You access item.Body which is the text body when you need the Html body.
You paste the entire body into the worksheet when you only want the table.

You need some extra variables:

  Dim Html As String
  Dim LcHtml As String
  Dim PosEnd As Long
  Dim PosStart As Long

Replace the If statement with:

    If TypeName(item) = "MailItem" And item.Subject = d Then

      Html = item.HTMLBody
      LcHtml = LCase(Html)
      PosStart = InStr(1, LcHtml, "<table")
      If PosStart > 0 Then
        PosEnd = InStr(PosStart, LcHtml, "</table>")
        If PosEnd > 0 Then
          Debug.Print "[" & Mid(Html, PosStart, PosEnd + 8 - PosStart) & "]"
          doClip.SetText Mid(Html, PosStart, PosEnd + 8 - PosStart)
          doClip.PutInClipboard
          ActiveSheet.Cells(1, 1).PasteSpecial "Text"
        End If
      End If

    End If

Collate tables from outlook mails into an Excel sheet using Excel VBA

1 Answers