VBA Code:
Sub ExtractTableFromEmailToExcel()
On Error GoTo ErrorHandler ' Start error handling
Dim OutlookApp As Object
Dim OutlookNamespace As Object
Dim Inbox As Object
Dim Subfolder As Object
Dim Item As Object
Dim HTMLDoc As Object
Dim Table As Object
Dim Row As Object
Dim Cell As Object
Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
Dim headersCopied As Boolean
' Define Outlook constants
Const olFolderInbox As Integer = 6
Const olMail As Integer = 43
' Initialize Outlook objects
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Inbox = OutlookNamespace.GetDefaultFolder(olFolderInbox)
' Replace "test" with the name of your specific subfolder
Set Subfolder = Inbox.Folders("test")
' Loop through each item in the subfolder
For Each Item In Subfolder.Items
If Item.Class = olMail Then
' Check for specific email subjects and select the corresponding worksheet
Select Case True
Case InStr(Item.Subject, "CB_Production Summary_") > 0
Set ws = ThisWorkbook.Sheets("Sheet1")
Case InStr(Item.Subject, "FS Production") > 0
Set ws = ThisWorkbook.Sheets("Sheet2")
Case InStr(Item.Subject, "Level 1") > 0
Set ws = ThisWorkbook.Sheets("Sheet3")
Case Else
' Skip the item if the subject does not match any of the specified patterns
GoTo skipitem
End Select
' Activate and clear the worksheet
ws.Activate
i = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1 ' Start at the next empty row
' Initialize HTML document
Set HTMLDoc = CreateObject("HTMLFile")
HTMLDoc.body.innerHTML = Item.HTMLBody
' Initialize headersCopied flag
headersCopied = False
' Loop through tables in the email body
For Each Table In HTMLDoc.getElementsByTagName("table")
' Loop through rows in the table
For Each Row In Table.Rows
' If headers have already been copied, skip the first row (assumed to be the header)
If headersCopied And Row.RowIndex = 0 Then
GoTo SkipHeader
End If
' Loop through cells in the row
j = 1
For Each Cell In Row.Cells
ws.Cells(i, j).Value = Cell.innerText
ws.Cells(i, j).WrapText = True
j = j + 1
Next Cell
i = i + 1
SkipHeader:
Next Row
headersCopied = True ' Mark that headers have been copied
Next Table
' Apply borders to the data range
With ws.Range(ws.Cells(1, 1), ws.Cells(i - 1, j - 1))
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.EntireColumn.AutoFit
End With
End If
skipitem:
Next Item
MsgBox "Table extraction complete!"
Exit Sub
ErrorHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical
End Sub
