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)
Dim olItem As Outlook.MailItem
CopyToExcel code sample
Option Explicit 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("Test") ' Process the message record Set olItem = Application.ActiveExplorer().Selection(1) 'Find the next empty line of the worksheet rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).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
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
Extract data from a Word document to create a contact.
More Run a Script samples can be found on these pages:
- Autoaccept a Meeting Request using Rules
- Create a rule to delete mail after a number of days
- Forward meeting details to another address
- How to Change the Font used for Outlook's RSS Feeds
- Keep Canceled Meetings on Outlook's Calendar
- Move messages CC'd to an address
- Outlook's Rules and Alerts: Run a Script
- Process messages received on a day of the week
- Read Outlook Messages using Plain Text
- Run a script rule: Autoreply using a template
- Run a Script Rule: Change Subject then Forward Message
- Run a script rule: Reply to a message
- Run a Script Rule: Send a new message when a message arrives
- Save all incoming messages to the hard drive
- Save Outlook email as a PDF
- Sort messages by Sender domain
- Use a run a script rule to mark messages read
- Use VBA to move messages with attachments