P130600439 100356 ACTI149 202 43.32
He found a code sample online that uses InStr and Split to locate the Outlook data and send it to the workbook, but he needed help making it work with his line of text.
In this code sample, I'm using late binding to set the Excel and RegEx objects instead of using early binding and selecting these two object libraries in VB Editor Tools, References menu. Generally speaking, using early binding is faster but it won't matter in this simple code. The code sample at copy-to-excel-regex.txt uses early binding. Late binding makes it easier to share macros as the references do not need to be set.
Read more about RegEx at Use RegEx to extract text from an Outlook email message
To use this code, add it to the VB Editor then create a Run a Script Rule.
To test the code on existing messages, replace
Sub CopyToExcel(olItem As Outlook.MailItem)
with
Sub CopyToExcel()
Dim olItem As Outlook.MailItem
and add
Set olItem = Application.ActiveExplorer().Selection(1)
after Set xlSheet = xlWB.Sheets("Sheet1")
CopyToExcel code sample
Option Explicit Private Const xlUp As Long = -4162 Sub CopyToExcel(olItem As Outlook.MailItem) Dim xlApp As Object Dim xlWB As Object Dim xlSheet As Object Dim vText, vText2, vText3, vText4, vText5 As Variant Dim sText As String Dim rCount As Long Dim bXStarted As Boolean Dim enviro As String Dim strPath As String Dim Reg1 As Object Dim M1 As Object Dim M As Object enviro = CStr(Environ("USERPROFILE")) 'the path of the workbook strPath = enviro & "\Documents\test.xlsx" On Error Resume Next Set xlApp = GetObject(, "Excel.Application") If Err <> 0 Then Application.StatusBar = "Please wait while Excel source is opened ... " Set xlApp = CreateObject("Excel.Application") bXStarted = True End If On Error GoTo 0 'Open the workbook to input the data Set xlWB = xlApp.Workbooks.Open(strPath) Set xlSheet = xlWB.Sheets("Sheet1") 'Find the next empty line of the worksheet rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row rCount = rCount + 1 sText = olItem.Body Set Reg1 = CreateObject("VBScript.RegExp") ' \s* = invisible spaces ' \d* = match digits ' \w* = match alphanumeric With Reg1 .Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*([\d-\.]*))" End With If Reg1.test(sText) Then ' each "(\w*)" and the "(\d)" are assigned a vText variable Set M1 = Reg1.Execute(sText) For Each M In M1 vText = Trim(M.SubMatches(1)) vText2 = Trim(M.SubMatches(2)) vText3 = Trim(M.SubMatches(3)) vText4 = Trim(M.SubMatches(4)) vText5 = Trim(M.SubMatches(5)) Next End If xlSheet.Range("B" & rCount) = vText xlSheet.Range("c" & rCount) = vText2 xlSheet.Range("d" & rCount) = vText3 xlSheet.Range("e" & rCount) = vText4 xlSheet.Range("f" & rCount) = vText5 xlWB.Close 1 If bXStarted Then xlApp.Quit End If Set M = Nothing Set M1 = Nothing Set Reg1 = Nothing Set xlApp = Nothing Set xlWB = Nothing Set xlSheet = Nothing End Sub
Customize the code
If you need to throw the entire line into one cell, you'll use the following code snippet. You could use a shorter pattern. (In my testing, the line wrapped in the cell automatically using the shorter pattern.)
.Pattern = "((P130[\w*-\s*]*[\d-\.]*))"
With Reg1 ' the entire string in one variable .Pattern = "((P130\w*\s*\w*\s*\w*\s*\w*\s*[\d-\.]*))" End With If Reg1.test(sText) Then Set M1 = Reg1.Execute(sText) For Each M In M1 vText = Trim(M.SubMatches(1)) Next End If xlSheet.Range("B" & rCount) = vText xlWB.Close 1
Run the macro on all messages in the folder
This macro looks for the pattern in each message in the folder and writes the found values, subject, and received time to the Excel sheet.
This macro was created by merging the macro above with the macro at "Outlook VBA: Work with Open Item or Selected Item".
To use, select a mail folder in Outlook then run the macro.
Option Explicit Private Const xlUp As Long = -4162 Sub CopyAllMessagesToExcel() Dim objOL As Outlook.Application Dim objItems As Outlook.Items Dim objFolder As Outlook.MAPIFolder Dim olItem As Outlook.MailItem Dim xlApp As Object Dim xlWB As Object Dim xlSheet As Object Dim vText, vText2, vText3, vText4, vText5 As Variant Dim sText As String Dim rCount As Long Dim bXStarted As Boolean Dim enviro As String Dim strPath As String Dim Reg1 As Object Dim M1 As Object Dim M As Object enviro = CStr(Environ("USERPROFILE")) 'the path of the workbook strPath = enviro & "\Documents\test.xlsx" On Error Resume Next Set xlApp = GetObject(, "Excel.Application") If Err <> 0 Then Application.StatusBar = "Please wait while Excel source is opened ... " Set xlApp = CreateObject("Excel.Application") bXStarted = True End If On Error GoTo 0 'Open the workbook to input the data Set xlWB = xlApp.Workbooks.Open(strPath) Set xlSheet = xlWB.Sheets("Sheet1") 'Find the next empty line of the worksheet rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row rCount = rCount + 1 Set objOL = Outlook.Application Set objFolder = objOL.ActiveExplorer.CurrentFolder Set objItems = objFolder.Items For Each olItem In objItems On Error Resume Next With olItem sText = olItem.Body Set Reg1 = CreateObject("VBScript.RegExp") ' \s* = invisible spaces ' \d* = match digits ' \w* = match alphanumeric With Reg1 .Pattern = "(Volume\s*(\d*)\s*Issue\s*(\d*))" End With If Reg1.Test(sText) Then ' each "(\w*)" and the "(\d)" are assigned a vText variable Set M1 = Reg1.Execute(sText) For Each M In M1 vText = Trim(M.SubMatches(1)) vText2 = Trim(M.SubMatches(2)) Next xlSheet.Range("B" & rCount) = vText xlSheet.Range("c" & rCount) = vText2 xlSheet.Range("d" & rCount) = .Subject xlSheet.Range("e" & rCount) = .ReceivedTime 'xlSheet.Range("f" & rCount) = vText5 ' next line rCount = rCount + 1 End If ' do whatever Debug.Print .Subject End With Next xlWB.Close 1 If bXStarted Then xlApp.Quit End If Set M = Nothing Set M1 = Nothing Set Reg1 = Nothing Set xlApp = Nothing Set xlWB = Nothing Set xlSheet = Nothing Set objItems = Nothing Set objFolder = Nothing Set objOL = Nothing End Sub
How to use this macro
First: You will need macro security set to low during testing.
Check your macro security in Outlook 2010 or 2013, at File, Options, Trust Center and then open Trust Center Settings. Change the Macro Settings to low for testing. In Outlook 2007 and older, itâs at Tools, Macro Security.
After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
To put the code in a module:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
More information as well as screenshots are at How to use the VBA Editor
More Information
- Autoaccept a Meeting Request using Rules
- Automatically Add a Category to Accepted Meetings
- Blocking Mail From New Top-Level Domains
- Convert RTF Messages to Plain Text Format
- Create a rule to delete mail after a number of days
- Create a Task from an Email using a Rule
- Create an Outlook Appointment from a Message
- Create Appointment From Email Automatically
- Delegates, Meeting Requests, and Rules
- Delete attachments from messages
- Forward meeting details to another address
- How to Change the Font used for Outlook's RSS Feeds
- How to Process Mail After Business Hours
- Keep Canceled Meetings on Outlook's Calendar
- Macro to Print Outlook email attachments as they arrive
- Move messages CC'd to an address
- Open All Hyperlinks in an Outlook Email Message
- Outlook AutoReplies: One Script, Many Responses
- Outlook's Rules and Alerts: Run a Script
- Process messages received on a day of the week
- Read Outlook Messages using Plain Text
- Receive a Reminder When a Message Doesn't Arrive?
- Run a script rule: Autoreply using a template
- Run a script rule: Reply to a message
- Run a Script Rule: Send a New Message when a Message Arrives
- Run Rules Now using a Macro
- Run-a-Script Rules Missing in Outlook
- Save all incoming messages to the hard drive
- Save and Rename Outlook Email Attachments
- Save Attachments to the Hard Drive
- Save Outlook Email as a PDF
- Sort messages by Sender domain
- Talking Reminders
- To create a rule with wildcards
- Use a Macro to Copy Data in an Email to Excel
- Use a Rule to delete older messages as new ones arrive
- Use a run a script rule to mark messages read
- Use VBA to move messages with attachments
Hi Diane,
Would there be a way to copy the received date/time of a selected e-mail and then paste it to the clipboard in this format:
"YYYYMMDD_HHMMSS"
Many thanks,
Ben
You could use a macro to copy it and chose the format.
format(item.receivedtime, "YYYYMMDD_HHMMSS")
A code sample to copy to clipboard is here -
https://www.slipstick.com/developer/code-samples/paste-clipboard-contents-vba/
Hi Diane, thank you for letting us enjoy your expertise. Makes my life a lot easier. I would like to use this script in a modified version on . I run into a challenge (for me although :-)) that the information which I would also like to write in the same sheet is not available in the MailItem object, but in AppointmeI.item. My knowledge about VB is just not sufficient to know how to approach this in the correct way. I managed to receive the data I needed form Appointmentitem, although not in combination the MailItem data. The data which I need: 'appointmentItem.RequiredAttendees' and '...Start' etc. is returned in a delimited string which I would like to split up vertically in a column within the same script. For each of the required attendees I need data from the Alias field which apparently is available within the MailItem object/ Exchange Global Address List. How to I let the script look up this data for each required attendee in the GAL and write it in the row in the active Excel sheet in which the required attendee is also written down after the split? Could you help me… Read more Âğ
Hi Diane. Thanks for your comprehensive code and following explanations.
I used the code but I ran into a problem: I tried to comment out the "On Error Resume Next" and "On Error GoTo 0" parts of the code to identify the problem and it gave me "Run-Time Error 429 - ActiveX Component can't create object" on the following part of your code:
"Set xlApp = GetObject(, "Excel.Application")"
Can you suggest any help or explanation?
Thanks in Advance
Hi Diane, thanks for the easy-to-follow code & comments! It really helps amateur programmers learn. Perhaps you or someone else can help me tweak this: I frequently receive emails containing lists of ISBN numbers, so I'd like to be able to run a macro on selected emails, have it find ALL ISBNs in the body, and compile them in an Excel sheet (ignoring duplicate ISBNs within a given email, but allowing duplicates between emails). As I understand it, my tasks for tweaking this code are:
1) Isolate ISBNs with RegExp (shouldn't be too hard, it's just a 13-digit numerical string)
2) Fetch all strings in an email that match the expression (QUESTION!!! Does this macro already do this? I really can't tell)
3) Check the set of strings for duplicates.
Does that sound about right?
Thanks for your help!
the macro on this page should work - just remove all of the lines that write to excel, keeping only thing one:
xlSheet.Range("B" & rCount) = vText - where vText will be the isbn - actually, you'll probably want to get all the isbns in a comma (or new list) seperated list and write the string to excel.
the more difficult problem is duplicates but I;m sure there are some excel functions for that. a quickie google found this:
https://stackoverflow.com/questions/32127581/removing-duplicate-values-from-a-string-in-visual-basic
Thank you! To avoid duplicates, I modified the RegExp to
([0-9]{13})(?![\s\S]*\1)
, which should find only one of each particular match. However, I'm not sure if this will throw off the script's loop, and I haven't gotten it finished enough to do a test run yet. As I understand it, the If block in your code loops through each RegExp match to enter them in the Excel. I would rather not put all ISBNs in a single comma-separate list because as each one gets entered in the Excel, I then want to have it run some other functions on the ISBN before finishing the loop and moving onto the next one. (To accomplish this, I am planning to call another macro after the linexlSheet.Range("B" & rCount) = vText
and beforerCount = rCount + 1
. Is that the right place to put that?)Thank you again for all your help!
.global = false after the .pattern will stop it after the first match, but that won't work if there is more than one code in an email.
My thought was to make the comma separated list, then you can remove dupes from it before entering it into Excel, one isbn per row.
Thank you Diane. You're absolutely right that my original method was too complicated. I've successfully made the script fetch the ISBNs from selected emails, however I'm running into a couple issues from there:
1) After running the macro, the excel sheet remains blank! It seems like
xlSheet.Range("E" & rCount) = vtext
is not working for some reason - or possibly it's not saving the excel file when finished?2) To pull the other info I'm going to need for each ISBN (e.g. title, publisher), I decided to call a user-define function rather than another macro, based off this code, but when I step through the macro with F8, it gets to
http.Open "GET", url, False
and then it exits the function. I have no experience with webscraping; do you have any idea why that might be happening?3) Lastly, when I run this macro with a blank excel file, for "Find the next empty line of the worksheet," rCount is 2, when it seems like it should be 1. Why is that?
Here's the pastebin for the full macro; if you have a few minutes to look it over I would be eternally grateful!!
HI Diane,
I need some automation for exporting data from the excel which is attached in the mail to the new excel file on my machine with some naming convention.
Usyally gets 100's of mail daily where I need to extract the data from each excel and then copy it to the template on my system.
Can you please suggest a solution for this.
Hi Diane, Thanks for all your commendable work with respect to VBscript.
I have been searching for a solution since the past two weeks for one of my critical projects. We have configured emails to be triggered for multiple instances and we receive approximately 1000 emails alerts a day stating the configured URLs are down. Most of them are false positives and it has become a tedious job for me to check all the urls manually. I am a novice in writing macros, but I have tried multiple ways for my problem and no luck.
I need a macro that will open the first url from all the selected emails in an excel and then checks for the http status of the same and return the status in the excel. I was able to find few solutions to check the http status automatically, but getting all the first urls from a set of emails is the toughest part where I have been stuck since the past 2 weeks. Could you please let me know if this can be ever achieved through a macro. If yes, how?
Thanks in advance.
you would use something like the macro on this page - to get the status. The last macro there shows how to get the page name. Status would be similar.
https://www.slipstick.com/developer/code-samples/open-hyperlinks-email-message/
Diane,
I am trying to extract all the content of the email. Currently it is opening and saving the Excel, but it is not doing anything with the data.
I am very new to Macros in general, would appreciate any help.
Thank you!
Hello Diane Enjoyed reading the above article I am a novice and I found quite easy to follow, I am looking for some code to do something slightly different, I have 2 mailbox's in my outlook my own and a shared inbox. The shared mailbox is the data i'm looking to extracted from ideally I am looking for a macro to run so I can get the below information from the email into a excel sheet Email Receipt Email Subject Date of Email Sender of email Body of Email The code I have been trying to use and change to my requirement is below Sub getDataFromOutlook() Dim OutlookApp As Outlook.Application Dim OutlookNamespace As Namespace Dim Folder As MAPIFolder Dim Outlookmail As Variant Dim i As Integer Set OutlookApp = New Outlook.Application Set OutlookNamespace = OutlookApp.GetNamespace("MAPI") Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("inbox") i = 1 For Each Outlookmail In Folder.items If Outlookmail.ReceivedTime >= Range("email_Receipt_Date").Value Then Range("email_Subject").Offset(i, 0) = Outlookmail.Subject Range("email_Subject").Offset(i, 0).Columns.AutoFit Range("email_Subject").Offset(i, 0).VerticalAlignment = xlTop Range("email_Date").Offset(i, 0).Value = OultlookMail.ReceivedTime Range("email_Date").Offset(i, 0).Columns.AutoFit Range("email_Date").Offset(i, 0).VerticalAlignment = xlTop Range("email_Sender").Offset(i, 0).Value = Outlookmail.SenderName Range("email_Sender").Offset(i, 0).Columns.AutoFit Range("email_Sender").Offset(i, 0).VerticalAlignment = xlTop Range("email_Body").Offset(i, 0).Value = Outlookmail.Body Range("email_Body").Offset(i, 0).Columns.AutoFit Range("email_Body").Offset(i, 0).VerticalAlignment = xlTop i = i + 1 End If Next… Read more Âğ
Hi, Diana,
I am trying to do something like the below.
When a mail arrives in outlook with a subject line "(Product) Dispatched Batch #3", I want to extract the 'product' name and Batch number, populate this information into a googlesheet/excel. When more mails arrive, for instance, "(Product) Dispatched Batch #8", I want the field to update to the new batch number (i.e. 8).
Is that possible?