Μετάβαση στο κύριο περιεχόμενο

Πώς να εξαγάγετε τον πίνακα σώματος email για να υπερέχετε στο Outlook;

Όταν λαμβάνετε ένα μήνυμα ηλεκτρονικού ταχυδρομείου που περιέχει ορισμένους πίνακες στο σώμα, μερικές φορές, ίσως χρειαστεί να εξάγετε όλους τους πίνακες από το σώμα μηνυμάτων σε ένα φύλλο εργασίας excel. Κανονικά, μπορείτε να αντιγράψετε και να επικολλήσετε τους πίνακες στο φύλλο εργασίας, αλλά, εδώ, θα μιλήσω για μια χρήσιμη μέθοδο για την επίλυση αυτής της εργασίας όταν υπάρχουν πολλοί πίνακες που πρέπει να εξαχθούν.

Εξαγωγή όλων των πινάκων από το σώμα μηνυμάτων του Outlook στο φύλλο εργασίας του Excel με κώδικα VBA


Εξαγωγή όλων των πινάκων από το σώμα μηνυμάτων του Outlook στο φύλλο εργασίας του Excel με κώδικα VBA

Εφαρμόστε τον ακόλουθο κώδικα VBA για εξαγωγή όλων των πινάκων από ένα σώμα μηνύματος στο φύλλο εργασίας του Excel.

1. Ανοίξτε το μήνυμα που θέλετε να εξαγάγετε τους πίνακες και, στη συνέχεια, κρατήστε πατημένο το ALT + F11 για να ανοίξετε το Microsoft Visual Basic για εφαρμογές παράθυρο.

2. Κλίκ Κύριο θέμα > Μονάδα μέτρησηςκαι επικολλήστε τον ακόλουθο κώδικα στο Μονάδα μέτρησης παράθυρο.

Κωδικός VBA: Εξαγωγή όλων των πινάκων από το σώμα μηνυμάτων στο φύλλο εργασίας του Excel:

Sub ImportTableToExcel()
Dim xMailItem As MailItem
Dim xTable As Word.Table
Dim xDoc As Word.Document
Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim I As Integer
Dim xRow As Integer
On Error Resume Next
Set xExcel = New Excel.Application
Set xWb = xExcel.Workbooks.Add
xExcel.Visible = True
Set xWs = xWb.Sheets(1)
xRow = 1
For Each xMailItem In Application.ActiveExplorer.Selection
    Set xDoc = xMailItem.GetInspector.WordEditor
    For I = 1 To xDoc.Tables.Count
        Set xTable = xDoc.Tables(I)
        xTable.Range.Copy
        xWs.Paste
        xRow = xRow + xTable.Rows.Count + 1
        xWs.Range("A" & CStr(xRow)).Select
    Next
Next
End Sub

doc πίνακες εξαγωγής για να υπερέχουν 1

3. Μετά την επικόλληση του παραπάνω κωδικού, ακόμα στο Microsoft Visual Basic για εφαρμογές παράθυρο, κάντε κλικ στην επιλογή Εργαλεία > αναφορές για να μεταβείτε στο Αναφορές-Έργο 1 πλαίσιο διαλόγου και επιλέξτε Βιβλιοθήκη αντικειμένων του Microsoft Word και Βιβλιοθήκη αντικειμένων του Microsoft Excel επιλογές από το Διαθέσιμες αναφορές πλαίσιο λίστας, δείτε το στιγμιότυπο οθόνης:

doc πίνακες εξαγωγής για να υπερέχουν 2

4. Στη συνέχεια κάντε κλικ στο κουμπί OK κουμπί για έξοδο από το παράθυρο διαλόγου και τώρα, παρακαλώ F5 κλειδί για την εκτέλεση του κώδικα, όλοι οι πίνακες στο σώμα μηνυμάτων έχουν εξαχθεί σε ένα νέο βιβλίο εργασίας, όπως φαίνεται το ακόλουθο στιγμιότυπο οθόνης:

doc πίνακες εξαγωγής για να υπερέχουν 3


Τα καλύτερα εργαλεία παραγωγικότητας γραφείου

Kutools για το Outlook - Πάνω από 100 ισχυρές δυνατότητες για υπερφόρτιση του Outlook σας

🤖 Βοηθός αλληλογραφίας AI: Άμεσα επαγγελματικά email με μαγεία AI -- με ένα κλικ για ιδιοφυείς απαντήσεις, τέλειος τόνος, πολυγλωσσική γνώση. Μεταμορφώστε τα email χωρίς κόπο! ...

📧 Αυτοματοποίηση ηλεκτρονικού ταχυδρομείου: Εκτός γραφείου (Διαθέσιμο για POP και IMAP)  /  Προγραμματισμός αποστολής email  /  Αυτόματο CC/BCC βάσει κανόνων κατά την αποστολή email  /  Αυτόματη προώθηση (Σύνθετοι κανόνες)   /  Αυτόματη προσθήκη χαιρετισμού   /  Διαχωρίστε αυτόματα τα μηνύματα ηλεκτρονικού ταχυδρομείου πολλών παραληπτών σε μεμονωμένα μηνύματα ...

📨 Διαχείριση e-mail: Εύκολη ανάκληση email  /  Αποκλεισμός απάτης email από υποκείμενα και άλλους  /  Διαγραφή διπλότυπων μηνυμάτων ηλεκτρονικού ταχυδρομείου  /  Προχωρημένη Αναζήτηση  /  Ενοποίηση φακέλων ...

📁 Συνημμένα ProΜαζική αποθήκευση  /  Αποσύνδεση παρτίδας  /  Συμπίεση παρτίδας  /  Αυτόματη αποθήκευση   /  Αυτόματη απόσπαση  /  Αυτόματη συμπίεση ...

🌟 Διασύνδεση Magic: 😊Περισσότερα όμορφα και δροσερά emojis   /  Ενισχύστε την παραγωγικότητά σας στο Outlook με προβολές με καρτέλες  /  Ελαχιστοποιήστε το Outlook αντί να κλείσετε ...

???? Με ένα κλικ Wonders: Απάντηση σε όλους με εισερχόμενα συνημμένα  /   Email κατά του phishing  /  🕘Εμφάνιση ζώνης ώρας αποστολέα ...

👩🏼‍🤝‍👩🏻 Επαφές & Ημερολόγιο: Μαζική προσθήκη επαφών από επιλεγμένα μηνύματα ηλεκτρονικού ταχυδρομείου  /  Διαχωρίστε μια ομάδα επαφής σε μεμονωμένες ομάδες  /  Κατάργηση υπενθυμίσεων γενεθλίων ...

Διανεμήθηκαν παραπάνω από 100 Χαρακτηριστικά Περιμένετε την εξερεύνηση σας! Κάντε κλικ εδώ για να ανακαλύψετε περισσότερα.

 

 

Comments (19)
No ratings yet. Be the first to rate!
This comment was minimized by the moderator on the site
re. Export all tables from Outlook message body to Excel worksheet with VBA code - i followed the instructions and it looked like it worked but where does the excel workbook go? I cant find it! (sorry, very new to this)
This comment was minimized by the moderator on the site
Hello,
The vba code will export the tables to a new opened workbook, and after getting the result, you just need to save the workbook to your desired location.
please have a try, hope this can help you!
This comment was minimized by the moderator on the site
i need to extract a table of data i receive every hour to a saved file

this doesn't work for me
This comment was minimized by the moderator on the site
Hi, i receive an email every hour with a table that i need to automatically send to a spreadsheet in a folder, will this code above work for that?
This comment was minimized by the moderator on the site
Even I receive many email with specific subject which I want to extract those tables in that email... help needed
This comment was minimized by the moderator on the site
Hello, arshad,
Do you mean to export all tables from the messages with the same subject into a worksheet?
This comment was minimized by the moderator on the site
This VBA code is not working for me... after run not getting exported in excel
This comment was minimized by the moderator on the site
I found a bug with this that I have not been able to resolve.

If I multi-select two emails, one with a single table and one with three tables, and run the code, Outlook crashes. But I noticed it is very specific to the order that the emails are initially selected.

1. For example if I click on the email with the three tables first, then ctrl-click the email with one table, the code runs without error.

2. If I do #1 first, then re-select the emails, this time click on the email with one table, then ctrl-click the email with three tables, it also run w/o error

3. Now if I close and restart Outlook and first click on the email with one table, then ctrl-click the email with three tables, Outlook crashes.

I also notice that when it does crash, it does it after it has copied/pasted the second table and before it does the third. In fact it doesn't even make it to the 'For I = 1 To xDoc.Tables.Count' to get the third table.

The tables are 43 rows and 7 columns. There is not other text in the emails and I removed all data from the tables, so it is not related to the data in them. I tried removed rows and at some point it will start working, but not sure what that is telling me.

Does anyone know why this is happening?
This comment was minimized by the moderator on the site
Same issue here as well. I tried to set the objects to nothing within each loop,but still it is not working.
This comment was minimized by the moderator on the site
Having the same issue here. No solution yet but thought I would let you know you are not alone.
This comment was minimized by the moderator on the site
Need help. I am a newbie and tried VBA code to copy table from outlook mail with specific subject to excel in specific location

Daily I receive a mail with subject "Backup Status today" and looking for a code to open that mail, copy the table and paste the table in excel in a specific location.

Issue: Code runs fine, no error. Mail gets opened and Excel gets opened but the table is not copied. Not sure where I went wrong. Please help.

Sub Openmail()

Dim xMailItem As Variant
Dim olNs As Outlook.NameSpace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim xTable As Word.Table
Dim xDoc As Word.document
Dim wordApp As Object
Dim xExcel As Object
Dim xWb As Workbook
Dim xWs As Worksheet
Dim I As Long
Dim v As Integer
Dim xRow As Integer
Dim StrFile$
On Error Resume Next

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items
Set wordApp = CreateObject("Word.Application")
Set xExcel = CreateObject("Excel.Application")

xRow = 1
I = 1

For Each xMailItem In olItms
If Int(xMailItem.ReceivedTime) >= Date Then
If InStr(xMailItem.Subject, "Backup Status today") > 0 Then
'xMailItem.Display
Set xDoc = xMailItem.GetInspector.WordEditor
For v = 1 To xDoc.Tables.Count
Set xTable = xDoc.Tables(v)
xTable.Range.Copy
StrFile = "C:\Users\priyanka.jeganathan\OneDrive - Accenture\Accenture\Learning\Daily DashBoard Basesheet.xlsx"
Set xWb = xExcel.Workbooks.Open(StrFile)
Set xWs = xWb.Worksheets("IRIS Daily")
xWs.Activate
xWs.Paste
xRow = xRow + xTable.Rows.Count + 1
xWs.Range("A" & CStr(xRow)).Select
Next
I = I + 1
End If
End If
Next xMailItem
xWs.Display
xWs.Range("A1:A6").ColumnWidth = 43
xWs.Rows("1:6").RowHeight = 16.5
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
This comment was minimized by the moderator on the site
Hello, Blessy,
If you want to open the email with specific subject and export the tables from the message body to an Excel file, may be the below VBA code can do you a favor, please try:

Sub ImportTableToExcelBySubject()
Dim xItem As Object
Dim xMailItem As MailItem
Dim xTable As Word.Table
Dim xDoc As Word.Document
Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim I As Integer
Dim xRow As Integer
Dim xFileDialog As FileDialog
On Error Resume Next
If Application.ActiveExplorer.CurrentFolder.Items.Count = 0 Then Exit Sub
Set xExcel = New Excel.Application
Set xFileDialog = xExcel.FileDialog(msoFileDialogFilePicker)
xFileDialog.Filters.Add "Excel Workbook", "*.xls*", 1
If xFileDialog.Show = 0 Then Exit Sub
Set xWb = xExcel.Workbooks.Open(xFileDialog.SelectedItems(1))
Set xWs = xWb.Worksheets(1)
xExcel.DisplayAlerts = False
xRow = 1
For Each xItem In Application.ActiveExplorer.CurrentFolder.Items
If xItem.Class = olMail Then
Set xMailItem = xItem
If InStr(xMailItem.Subject, "Backup Status today") > 0 Then 'enter the subject into the double quote
Set xDoc = xMailItem.GetInspector.WordEditor
For I = 1 To xDoc.Tables.Count
Set xTable = xDoc.Tables(I)
xTable.Range.Copy
xWs.Paste
xRow = xRow + xTable.Rows.Count + 1
xWs.Range("A" & CStr(xRow)).Select
Next
xMailItem.Display
End If
End If
Next
xWb.Save
xExcel.DisplayAlerts = True
xExcel.Visible = True
End Sub
This comment was minimized by the moderator on the site
Thank you Skyyang. It works. Except it fetches all the mail with "Backup Status today" wherein I want this code to run on mails received today. Have updated your code, but still it copies the table from all the mails received in the past too. Please help.


Sub ImportTableToExcelBySubject()
Dim xItem As Object
Dim xMailItem As MailItem
Dim xTable As Word.Table
Dim xDoc As Word.document
Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim I As Integer
Dim xRow As Integer
Dim xFileDialog As FileDialog
Dim Drt As Date
On Error Resume Next
If Application.ActiveExplorer.CurrentFolder.Items.Count = 0 Then Exit Sub
Set xExcel = New Excel.Application
Set xFileDialog = xExcel.FileDialog(msoFileDialogFilePicker)
xFileDialog.Filters.Add "Excel Workbook", "*.xls*", 1
If xFileDialog.Show = 0 Then Exit Sub
Set xWb = xExcel.Workbooks.Open(xFileDialog.SelectedItems(1))
Set xWs = xWb.Worksheets(1)
xExcel.DisplayAlerts = False
xRow = 1
For Each xItem In Application.ActiveExplorer.CurrentFolder.Items
If xItem.Class = olMail Then
Set xMailItem = xItem
Drt = xMailItem.ReceivedTime
If Drt <= Date And InStr(xMailItem.Subject, "Backup Status today") > 0 Then 'enter the subject into the double quote
Set xDoc = xMailItem.GetInspector.WordEditor
For I = 1 To xDoc.Tables.Count
Set xTable = xDoc.Tables(I)
xTable.Range.Copy
xWs.Paste
xRow = xRow + xTable.Rows.Count + 1
xWs.Range("A" & CStr(xRow)).Select
Next
xMailItem.Display
End If
End If
Next
xWb.Save
xExcel.DisplayAlerts = True
xExcel.Visible = True
End Sub
This comment was minimized by the moderator on the site
What reference/ object library needs to be activated in excel? I am actually new to VBA and learning .
This comment was minimized by the moderator on the site
Hi, Blessy,

If you just need to import the tables with specific subject, you should apply the below VBA code. First, you need to select the email with the subject you need, and then run this code. Please try.

Sub ImportTableToExcelBySubject()
Dim xMailItem As MailItem
Dim xTable As Word.Table
Dim xDoc As Word.Document
Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim I As Integer
Dim xRow As Integer
Dim xFileDialog As FileDialog
On Error Resume Next
Set xExcel = New Excel.Application
Set xFileDialog = xExcel.FileDialog(msoFileDialogFilePicker)
xFileDialog.Filters.Add "Excel Workbook", "*.xls*", 1
If xFileDialog.Show = 0 Then Exit Sub
Set xWb = xExcel.Workbooks.Open(xFileDialog.SelectedItems(1))
Set xWs = xWb.Worksheets(1)
xExcel.DisplayAlerts = False
xRow = 1
For Each xMailItem In Application.ActiveExplorer.Selection
If InStr(xMailItem.Subject, "Backup Status today") > 0 Then
Set xDoc = xMailItem.GetInspector.WordEditor
For I = 1 To xDoc.Tables.Count
Set xTable = xDoc.Tables(I)
xTable.Range.Copy
xWs.Paste
xRow = xRow + xTable.Rows.Count + 1
xWs.Range("A" & CStr(xRow)).Select
Next
End If
Next
xWb.Save
xExcel.DisplayAlerts = True
xExcel.Visible = True
End Sub
This comment was minimized by the moderator on the site
Thank you, Skyyang for your response. My whole target is to run the code in outlook VBA so that it searches for mail recieved on "current date" in other words "today" with subject "Backup Status today" and copy the table from that mail to excel in tabular format. Please help on this.. instead of we select that mail, let the code selects the mail and copy the content to excel. is there a way... ? Please help, it will save my day.
This comment was minimized by the moderator on the site
Need help, VBA to copy table from outlook mail with specific subject to excel in a specific location

I receive a mail with subject "Backup Status today" with a table of 2 columns and 6 rows in my Inbox. Trying to write a code to open the mail and copy the table and paste it in excel in a specific location.

Issue: Code runs fine, no error. Mails opens and also the excel file opens. But the table is not copied. Please help on this.

Sub Openmail()

Dim xMailItem As Variant
Dim olNs As Outlook.NameSpace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim xTable As Word.Table
Dim xDoc As Word.document
Dim wordApp As Object
Dim xExcel As Object
Dim xWb As Workbook
Dim xWs As Worksheet
Dim I As Long
Dim v As Integer
Dim xRow As Integer
Dim StrFile$
On Error Resume Next

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items
Set wordApp = CreateObject("Word.Application")
Set xExcel = CreateObject("Excel.Application")

xRow = 1
I = 1

For Each xMailItem In olItms
If Int(xMailItem.ReceivedTime) >= Date Then
If InStr(xMailItem.Subject, "Backup Status today") > 0 Then
'xMailItem.Display
Set xDoc = xMailItem.GetInspector.WordEditor
For v = 1 To xDoc.Tables.Count
Set xTable = xDoc.Tables(v)
xTable.Range.Copy
StrFile = "C:\Users\priyanka.jeganathan\OneDrive - Accenture\Accenture\Learning\Daily DashBoard Basesheet.xlsx"
Set xWb = xExcel.Workbooks.Open(StrFile)
Set xWs = xWb.Worksheets("IRIS Daily")
xWs.Activate
xWs.Paste
xRow = xRow + xTable.Rows.Count + 1
xWs.Range("A" & CStr(xRow)).Select
Next
I = I + 1
End If
End If
Next xMailItem
xWs.Display
xWs.Range("A1:A6").ColumnWidth = 43
xWs.Rows("1:6").RowHeight = 16.5
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
This comment was minimized by the moderator on the site
How to open a mail with specific subject and copy the table in spreadsheet with a specific name. Please help.
This comment was minimized by the moderator on the site
This works great! Thank you very much
There are no comments posted here yet
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations