Sub ExtractTablesFromEmailsToExcelDirectly()
Dim olApp As Object
Dim olNamespace As Object
Dim olSelection As Object
Dim olMail As Object
Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlSheet As Object
Dim tableHTML As String
Dim tableContent As Object
Dim i As Long
Dim j As Long
Dim sheetIndex As Long
Dim subjectLast25 As String

' Create Outlook application and namespace objects
Set olApp = CreateObject("Outlook.Application")
Set olNamespace = olApp.GetNamespace("MAPI")

' Access selected items in Outlook
Set olSelection = olApp.ActiveExplorer.Selection

' Check if there are selected items
If olSelection.Count = 0 Then
    MsgBox "No emails selected.", vbExclamation
    Exit Sub
End If

' Create Excel application
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkbook = xlApp.Workbooks.Add

sheetIndex = 1

' Loop through each selected email
For Each olMail In olSelection
    ' Check if the item is an email
    If olMail.Class = 43 Then ' 43 corresponds to olMail
        ' Extract HTML body of the email
        tableHTML = olMail.HTMLBody

        ' Check if the email contains a table
        If InStr(1, tableHTML, "<table", vbTextCompare) > 0 Then
            ' Extract tables directly from HTML
            Set tableContent = CreateObject("htmlfile")
            tableContent.Open
            tableContent.write tableHTML

            ' Get the last 25 characters of the email subject
            subjectLast25 = Right(olMail.Subject, 25)
            subjectLast25 = Replace(subjectLast25, "/", "_") ' Replace slashes to avoid invalid sheet names

            ' Add a new sheet for each table
            If sheetIndex > xlWorkbook.Sheets.Count Then
                xlWorkbook.Sheets.Add After:=xlWorkbook.Sheets(xlWorkbook.Sheets.Count)
            End If
            Set xlSheet = xlWorkbook.Sheets(sheetIndex)
            xlSheet.Name = subjectLast25

            ' Get table content
            Set tableHTML = tableContent.getElementsByTagName("table")
            For Each tbl In tableHTML
                For i = 0 To tbl.Rows.Length - 1
                    For j = 0 To tbl.Rows(i).Cells.Length - 1
                        xlSheet.Cells(i + 1, j + 1).Value = tbl.Rows(i).Cells(j).innerText
                    Next j
                Next i
                sheetIndex = sheetIndex + 1
            Next tbl
        End If
    End If
Next olMail

' Clean up
Set olSelection = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
Set xlSheet = Nothing
Set xlWorkbook = Nothing
Set xlApp = Nothing

MsgBox "Tables have been successfully extracted to Excel.", vbInformation

End Sub

sssssssssssnkfnkjkjbkjbkl