macro to export outlook emails to excel

Status
Not open for further replies.

Wichiepr

Member
Outlook version
Outlook 2016 64 bit
Email Account
IMAP
HI

I am really new in VBA. Excuse me English. I read a lot of article about this, try some but I still don't get it. I need to read this text and extract it to a row in Excel in a different cell each one. I have a formula on cell B-8 to execute some logic. After that I have an app to convert it in cvs, I don't know i can do it from excel since is open. I need to Use the file, close it and replace the file with a new one every time. Path C:\canvas\emails.xlsx

El número de orden de trabajo referenciado es C5937015 Cell B-1
Edificio: Store #12012 Cell B-2
Prioridad: P3 - Alto Cell B-3
País, Estado, Ciudad: PR, PR, Fajardo Cell B-4
Piso: All: 100 CALLE 12
Nombre de contacto: NORAIVETTE GONZALEZ
Teléfono de contacto: (787) 863-1475 Cell 7

Thanks for your help
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
This is an outlook macro that uses regex to get values from email and send it to excel.
Use a macro to copy data in Outlook email to Excel workbook

Switching it to an Excel macro won't be too hard - you would remove the excel app parts and reference outlook using a similar method
Dim olApp As Outlook.Application
Dim olItem As Outlook.MailItem
Dim blnCreated As Boolean
Dim olNs As Outlook.Namespace

Set olApp = Outlook.Application
If olApp Is Nothing Then
Set olApp = Outlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If


See Get two (or more) values from a message (it's the second macro) for regex to get multiple items from a message.
 

Wichiepr

Member
Outlook version
Outlook 2016 64 bit
Email Account
IMAP
This is an outlook macro that uses regex to get values from email and send it to excel.
Use a macro to copy data in Outlook email to Excel workbook

Switching it to an Excel macro won't be too hard - you would remove the excel app parts and reference outlook using a similar method
Dim olApp As Outlook.Application
Dim olItem As Outlook.MailItem
Dim blnCreated As Boolean
Dim olNs As Outlook.Namespace

Set olApp = Outlook.Application
If olApp Is Nothing Then
Set olApp = Outlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If


See Get two (or more) values from a message (it's the second macro) for regex to get multiple items from a message.

First Thanks for taking your time, I try the Macro and try to add some other other patter like this and I am getting and error on the Select i, I really don't know how to proceed

For i = 1 To 3

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 & "\Canvas\emails.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("Data")
'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

For i = 1 To 3
With Reg1
Select Case i
Case 1
.Pattern = "(Order ID\s[:]([\w-\s]*)\s*)\n"
.Global = False

Case 2
.Pattern = "(Date[:]([\w-\s]*)\s*)\n"
.Global = False

Case 3
.Pattern = "(([\d]*\.[\d]*))\s*\n"
.Global = False
End Select

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

I want to run it form Outlook Rules and I don't know how
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
This snippet *should* work - copy each case block to cover all of the sections you need to find and adjust the i = 3 line to reflect the correct number. Add an if i = nn lines as needed.

The pattern for the phone # will be something like this, assuming they always use the pattern in your example.
((\([0-9]{3}\)-([0-9]{3})-([0-9]{4}))

Code:
For i = 1 To 3
With Reg1

Select Case i
Case 1 ' assumes always starts with C
.Pattern = "(referenciado es (C[\d]*))\n"
.Global = False

Case 2 ' always numbers
.Pattern = "(Store #([\d]*))\n"
.Global = False

Case 3 ' always letters
.Pattern = "(PR, PR,([\w]*)\n"
.Global = False

End Select

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

   Debug.Print M.SubMatches(1)
            strResult= M.SubMatches(1)
     If i = 1 then vText = StrResult
     If i = 2 then vText2 = StrResult
     If i = 3 then vText3 = StrResult
   
Next
End If
 

Wichiepr

Member
Outlook version
Outlook 2016 64 bit
Email Account
IMAP
First Thanks for taking your time, I try the Macro and try to add some other other patter like this and I am getting and error on the Select i, I really don't know how to proceed

For i = 1 To 3

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 & "\Canvas\emails.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("Data")
'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

For i = 1 To 3
With Reg1
Select Case i
Case 1
.Pattern = "(Order ID\s[:]([\w-\s]*)\s*)\n"
.Global = False

Case 2
.Pattern = "(Date[:]([\w-\s]*)\s*)\n"
.Global = False

Case 3
.Pattern = "(([\d]*\.[\d]*))\s*\n"
.Global = False
End Select

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

I want to run it form Outlook Rules and I don't know how
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Well, for starters, For i = 1 To 3 shouldn't be above option explicit.

Do you want everything in column B? (Records are usually put in rows.)

This works here - when you use wildcards (.*), you need to have a unique word to search on.

This should work as a rule - it needs ot be in a module, not in thisoutlooksession.


Code:
Option Explicit
Private Const xlUp As Long = -4162

Private Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5, vText6, vText7 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
Dim i
Dim strResult As String

enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Canvas\emails.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("Data")
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")
For i = 1 To 7

With Reg1

Select Case i
' El número de orden de trabajo referenciado es C5937015 Cell B-1
Case 1 ' assumes always starts with C
.Pattern = "(referenciado es (C[\d]*))"
.Global = False

'Edificio: Store #12012 Cell B-2
Case 2 ' always numbers
.Pattern = "(Store #([\d]*))"
.Global = False

'Prioridad: P3 - Alto Cell B-3
Case 3
.Pattern = "(Prioridad:\s*(.*))\r"
.Global = False

'País, Estado, Ciudad: PR, PR, Fajardo Cell B-4
Case 4 ' always letters
.Pattern = "(PR, PR,\s*(.*))\r"
.Global = False

'Piso: All: 100 CALLE 12
Case 5
.Pattern = "(All: (.*))\r"
.Global = False

'Nombre de contacto: NORAIVETTE GONZALEZ
Case 6
.Pattern = "(contacto: ([\w ]*))"
.Global = False

'Teléfono de contacto: (787) 863-1475 Cell 7
Case 7
.Pattern = "(Teléfono de contacto:\s*(.*))\r"
.Global = False

End Select

End With

If Reg1.Test(sText) Then

Set M1 = Reg1.Execute(sText)
For Each M In M1

Debug.Print M.SubMatches(1)
strResult = M.SubMatches(1)
If i = 1 Then vText = strResult
If i = 2 Then vText2 = strResult
If i = 3 Then vText3 = strResult
If i = 4 Then vText4 = strResult
If i = 5 Then vText5 = strResult
If i = 6 Then vText6 = strResult
If i = 7 Then vText7 = strResult

Next
End If
Next i
Debug.Print vText
Debug.Print "2: " & vText2
Debug.Print "3: " & vText3
Debug.Print "4: " & vText4
Debug.Print "5: " & vText5
Debug.Print "6: " & vText6
Debug.Print "7: " & vText7

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


If you want to test it on messages in your mailbox,
run this macro:
Code:
Sub TestMacro()
Dim olItem As Outlook.MailItem
Set olItem = Application.ActiveExplorer.Selection.Item(1)
CopyToExcel olItem
End Sub
 

Wichiepr

Member
Outlook version
Outlook 2016 64 bit
Email Account
IMAP
Well, for starters, For i = 1 To 3 shouldn't be above option explicit.

Do you want everything in column B? (Records are usually put in rows.)

This works here - when you use wildcards (.*), you need to have a unique word to search on.

This should work as a rule - it needs ot be in a module, not in thisoutlooksession.


Code:
Option Explicit
Private Const xlUp As Long = -4162

Private Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5, vText6, vText7 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
Dim i
Dim strResult As String

enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Canvas\emails.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("Data")
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")
For i = 1 To 7

With Reg1

Select Case i
' El número de orden de trabajo referenciado es C5937015 Cell B-1
Case 1 ' assumes always starts with C
.Pattern = "(referenciado es (C[\d]*))"
.Global = False

'Edificio: Store #12012 Cell B-2
Case 2 ' always numbers
.Pattern = "(Store #([\d]*))"
.Global = False

'Prioridad: P3 - Alto Cell B-3
Case 3
.Pattern = "(Prioridad:\s*(.*))\r"
.Global = False

'País, Estado, Ciudad: PR, PR, Fajardo Cell B-4
Case 4 ' always letters
.Pattern = "(PR, PR,\s*(.*))\r"
.Global = False

'Piso: All: 100 CALLE 12
Case 5
.Pattern = "(All: (.*))\r"
.Global = False

'Nombre de contacto: NORAIVETTE GONZALEZ
Case 6
.Pattern = "(contacto: ([\w ]*))"
.Global = False

'Teléfono de contacto: (787) 863-1475 Cell 7
Case 7
.Pattern = "(Teléfono de contacto:\s*(.*))\r"
.Global = False

End Select

End With

If Reg1.Test(sText) Then

Set M1 = Reg1.Execute(sText)
For Each M In M1

Debug.Print M.SubMatches(1)
strResult = M.SubMatches(1)
If i = 1 Then vText = strResult
If i = 2 Then vText2 = strResult
If i = 3 Then vText3 = strResult
If i = 4 Then vText4 = strResult
If i = 5 Then vText5 = strResult
If i = 6 Then vText6 = strResult
If i = 7 Then vText7 = strResult

Next
End If
Next i
Debug.Print vText
Debug.Print "2: " & vText2
Debug.Print "3: " & vText3
Debug.Print "4: " & vText4
Debug.Print "5: " & vText5
Debug.Print "6: " & vText6
Debug.Print "7: " & vText7

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


If you want to test it on messages in your mailbox,
run this macro:
Code:
Sub TestMacro()
Dim olItem As Outlook.MailItem
Set olItem = Application.ActiveExplorer.Selection.Item(1)
CopyToExcel olItem
End Sub
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
K Macro to search emails between two time slots on public folders with excel export Outlook VBA and Custom Forms 12
B Macro To Create Rule To Export From Certain Folder Email Information in one workbook multiple sheets Outlook VBA and Custom Forms 0
D Macro to export mail data based on assigned category Using Outlook 3
E Macro to export BCM business data to CSV file BCM (Business Contact Manager) 1
witzker Macro to move @domain.xx of a Spammail to Blacklist in Outlook 2019 Outlook VBA and Custom Forms 4
S Macro for other actions - Outlook 2007 Outlook VBA and Custom Forms 18
C Macro to extract sender name & subject line of incoming emails to single txt file Outlook VBA and Custom Forms 3
L Macro/VBA to Reply All, with the original attachments Outlook VBA and Custom Forms 2
S Macro to move “Re:” & “FWD:” email recieved the shared inbox to a subfolder in outlook Outlook VBA and Custom Forms 0
S Outlook Macro to send auto acknowledge mail only to new mails received to a specific shared inbox Outlook VBA and Custom Forms 0
S Outlook Macro to move reply mail based on the key word in the subjectline Outlook VBA and Custom Forms 0
Eike Move mails via macro triggered by the click of a button? Outlook VBA and Custom Forms 0
S Macro or plug-in to see if specific person was included in this email Outlook VBA and Custom Forms 3
U Macro for reminders,tasks,calendar Outlook VBA and Custom Forms 4
V macro runs slower on startup than after Outlook VBA and Custom Forms 3
N Macro to move all recipients to CC while replying Outlook VBA and Custom Forms 0
A VBA macro for 15 second loop in send and received just for 1 specific mailbox Outlook VBA and Custom Forms 1
G VBA Macro Calendar Printing Assistant 4
R Help Revising VBA macro to delete email over different time span Outlook VBA and Custom Forms 0
M Outlook macro to automate search and forward process Outlook VBA and Custom Forms 6
R Macro Schedule every day in Outlook Using Outlook 0
L Moving emails with similar subject and find the timings between the emails using outlook VBA macro Outlook VBA and Custom Forms 1
Healy Consultants Macro to remove inside organization distribution list email address when reply to all recepients Outlook VBA and Custom Forms 0
geofferyh Cannot get Macro to SAVE more than one message attachment??? Outlook VBA and Custom Forms 5
N How can I increase/faster outlook VBA Macro Speed ? Using Outlook 2
4 Macro to set the category of Deleted Item? Outlook VBA and Custom Forms 2
D.Moore Folder view settings by VBA macro Outlook VBA and Custom Forms 57
A Outlook macro to create search folder with mail categories as criteria Outlook VBA and Custom Forms 3
Dave A Run macro on existing appointment when it changes Outlook VBA and Custom Forms 1
V Outlook Macro to show Flagged messages Outlook VBA and Custom Forms 2
O Run macro automatically at sending an email Using Outlook 11
R Retain Original Message When Forwarding With Macro Outlook VBA and Custom Forms 3
C Macro to add multiple recipients to message Outlook VBA and Custom Forms 3
B Reply and replyall macro is not working Outlook VBA and Custom Forms 1
O Macro - paste as plain text Outlook VBA and Custom Forms 2
J Help Please!!! Outlook 2016 - VBA Macro for replying with attachment in meeting invite Outlook VBA and Custom Forms 9
witzker Macro to set contact reminder to next day 9:00 Outlook VBA and Custom Forms 45
M Adding Macro to populate "to" "subject" "body" not deleting email string below. Outlook VBA and Custom Forms 5
E Copying data from e-mail attachement to EXCEL file via macro Outlook VBA and Custom Forms 38
M Macro to add date/time stamp to subject Outlook VBA and Custom Forms 4
R VBA macro - new message Outlook VBA and Custom Forms 3
S Example VBA Macro - To Conditionally Change the From Account and Add a BCC Address on Emails Outlook VBA and Custom Forms 11
S Macro using .SendUsingAccount only works the first time, after starting Outlook Outlook VBA and Custom Forms 4
S VBA Macro - Run-time error '424': object required - Help Please Outlook VBA and Custom Forms 3
B VBA Macro for assigning multiple Categories to an email in my Inbox Outlook VBA and Custom Forms 1
N Macro for attachment saved and combine Outlook VBA and Custom Forms 1
Sabastian Samuel HOW DO I FORWARD AN EMAIL WITH MACRO using an email that in the body of another email Outlook VBA and Custom Forms 3
C Search with Google Macro? Outlook VBA and Custom Forms 4
J Outlook 2013 Extract Flag Completed dates to Excel Macro Outlook VBA and Custom Forms 16
M Slow VBA macro in Outlook Outlook VBA and Custom Forms 5

Similar threads

Top