Copy or Export Outlook Mail to Excel

John Ferretti

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Office 365 Exchange
Hi, I have a VBA Code to export incoming emails to excel and it does not work. If i paste the code, since i do not know what the items mean can someone highlight what i need to edit to cater it to the folder location of the excel file and other. I really just want to make a macro button in the email that extracts the date, name, and subject to excel so i can do it on a one off basis when i press the button.
 

John Ferretti

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Office 365 Exchange
Any error messages?

I have a code sample here - Macro to Export Outlook Fields to Excel - it works with one or more selected message.

Thanks Diane, your code worked. I think because the code I had didnt factor in for microsoft exchange.

Could you also help me change where it looks for the excel file? It is on a different drive in a subfolder not my user folder.

Also I do not need the body, just the subject and not sure what i can remove to get the subject.

Basically, I wanted the date in column A, Subject in Column E, sender in column N on the sheet i am using.

And if i create the radio button in outlook to run it will it automatically add the next email on the next line?
 

John Ferretti

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Office 365 Exchange
Actually I figured some stuff out, but it keeps overwriting the same row, it wont add a separate email to the next row.

Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String

Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColA, strColC, strColD, strColE, strColF As String

' Get Excel set up
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("Pipeline Agenda")
' Process the message record

On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1

' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection

Set olItem = obj

'collect the fields
strColA = olItem.ReceivedTime
strColC = olItem.SenderName
strColD = olItem.To
strColE = olItem.Subject
strColF = olItem.Categories

' Get the Exchange address
' if not using Exchange, this block can be removed
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.Session.CreateRecipient(strColC)

If InStr(1, strColC, "/") > 0 Then
' if exchange, get smtp address
Select Case recip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
End Select
End If
' End Exchange section


'write them in the excel sheet
xlSheet.Range("A" & rCount) = strColA
xlSheet.Range("n" & rCount) = strColC
xlSheet.Range("d" & rCount) = strColD
xlSheet.Range("e" & rCount) = strColE
xlSheet.Range("f" & rCount) = strColF

'Next row
rCount = rCount + 1

Next

xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If

Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
This would tell it to find the next line when you restart the macro - does B have a value? If not change it to a column that will always have a value - N maybe?
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row

if you are doing more than 1 email at a time, it should add all, because rcount will go up - but if you are adding one at a time, then it won't.

If it's not that, add debug.print rcount after each line beginning with rCount then open the immediate window (on view menu) and run the macro. Do the numbers increment up by one?

To run it automatically, you need to use a run a script version in rules or an itemadd version that watches the folder for new items. There is an itemadd on the page with this macro.
 

John Ferretti

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Office 365 Exchange
Diane, you are a life saver, last question, what lines do i change to get it to go to this folder and this file:
Folder Location is this, O: is not my user drive, but a shared network drive
O:\Lease Credit Request\z2017 Pipeline Reports
File is 2017 Pipeline.xlsx
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
This tells it to use the logged in user's docs folder:
strPath = enviro & "\Documents\test.xlsx"
change it to
strPath = "O:\Lease Credit Request\z2017 Pipeline Reports\test.xlsx"
 
Top