Use a Macro to Copy Data in an Email to Excel

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:

1. Right click on Project1 and choose Insert > Module
2. Copy and paste the macro into the new module.

More information as well as screenshots are at How to use the VBA Editor