Avatar of daintysally
daintysallyFlag for United States of America asked on

Export emails from Outlook Inbox folder to Excel

Hi Experts,

I am trying to export emails from the Inbox in Outlook to an existing Excel worksheet.  I was able to modify the code below to export the fields that I need from the Inbox to an Excel spreadsheet, but I need to instead append the records from the Inbox to the next blank row in the existing worksheet.  The worksheet has a header row in the first row and a count column in column A.  I also need to add some code that will populate the count column when a new record is added.  The count is in increments of '1'.   Can someone tell me what I need to add to the code below to make this happen?


Sub Export2Excel()
  On Error GoTo ErrHandler
    Dim appExcel As Excel.Application
    Dim wkb As Excel.Workbook

Dim wks As Excel.Worksheet

Dim rng As Excel.Range

Dim strSheet As String

Dim strPath As String

Dim intRowCounter As Integer

Dim intColumnCounter As Integer

Dim msg As Outlook.MailItem

Dim nms As Outlook.NameSpace

Dim fld As Outlook.MAPIFolder

Dim itm As Object
    strSheet = "Sample.xlsx"
        strPath = "C:\Desktop\"

strSheet = strPath & strSheet

Debug.Print strSheet
    'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
   
'Handle potential errors with Select Folder dialog box.

If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"

Exit Sub

ElseIf fld.DefaultItemType <> olMailItem Then

MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"

Exit Sub

ElseIf fld.Items.Count = 0 Then

MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"

Exit Sub

End If
    'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")

appExcel.Workbooks.Open (strSheet)

Set wkb = appExcel.ActiveWorkbook

Set wks = wkb.Sheets(1)

wks.Activate

appExcel.Application.Visible = True
   
   
'Copy field items in mail folder.
For Each itm In fld.Items

intColumnCounter = 2

Set msg = itm
intRowCounter = intRowCounter + 2
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.From
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn


Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
 
Exit Sub

ErrHandler:
If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, _
"Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, _
"Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
   
End Sub
VB ScriptOutlookMicrosoft Excel

Avatar of undefined
Last Comment
daintysally

8/22/2022 - Mon
ASKER
daintysally

Can anyone help me with this?
dlmille

Yes.

Before you get into your loop processing the folder items, you need to determine the next row from which you'll be writing with a statement like:

To append and initialize record counter, and keep it counting in theloop:
 'get inital row for output
    intRowCounter = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
    
    'initialize record count

    If intRecCounter = 2 Then
       intRecCounter = 0
    Else
       intRecCounter = wks.Cells(intRowCounter, 1).Value
    End If
      
    'Copy field items in mail folder.
    For Each itm In fld.Items

        intColumnCounter = 2

        Set msg = itm
        
        intRowCounter = intRowCounter + 2
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.Sender 'not from
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.Subject
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.SentOn
        
        'increment Record counter
        intRecCounter = intRecCounter + 1 'increment the prior count
        'output the record count
        wks.Cells(intRowCounter, 1).Value = intRecCounter

    Next itm

Open in new window

That's your initial record counter.  It needs to be initialized to 0, then incremented in your loop on each item loop, then reported out after each record is processed.

I tested your code and fixed it a bit, including a bug: you were using mailItem.From and from is not a property of the mailitem.  You want to use Sender.

E.g., msg.Sender

Also don't forget to write a few more lines of code to close out the Excel spreadsheet, or you'll lose all that good logging!  I added code at the end for that, too ;)

Finally, I played a bit with your error Handling.  You can go to a gracefulExit if successful, then after the ErrorHandling code, it can fall to gracefulExit as well.  In the gracefulExit section, you can test to see if the wkb is open, if the process was successful and save that file, closing out, then setting your objects to nothing.

Here's your code:
Option Explicit

Sub Export2Excel()
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
Dim intRecCounter As Long
Dim bSuccess As Boolean

On Error GoTo ErrHandler
    strSheet = "Sample.xlsx"
    strPath = "C:\Desktop\"

    strSheet = strPath & strSheet

    Debug.Print strSheet
    'Select export folder
    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder

    'Handle potential errors with Select Folder dialog box.

    If fld Is Nothing Then
        MsgBox "There are no mail messages to export", vbOKOnly, _
               "Error"

        Exit Sub

    ElseIf fld.DefaultItemType <> olMailItem Then

        MsgBox "There are no mail messages to export", vbOKOnly, _
               "Error"

        Exit Sub

    ElseIf fld.Items.Count = 0 Then

        MsgBox "There are no mail messages to export", vbOKOnly, _
               "Error"

        Exit Sub

    End If
    
    'Open and activate Excel workbook.
    Set appExcel = CreateObject("Excel.Application")

    appExcel.Workbooks.Open (strSheet)

    Set wkb = appExcel.ActiveWorkbook

    Set wks = wkb.Sheets(1)

    wks.Activate

    appExcel.Application.Visible = True


    'get inital row for output
    intRowCounter = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
    
    'initialize record count

    If intRecCounter = 2 Then
       intRecCounter = 0
    Else
       intRecCounter = wks.Cells(intRowCounter, 1).Value
    End If
      
    'Copy field items in mail folder.
    For Each itm In fld.Items

        intColumnCounter = 2

        Set msg = itm
        
        intRowCounter = intRowCounter + 2
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.Sender 'not from
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.Subject
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.SentOn
        
        'increment Record counter
        intRecCounter = intRecCounter + 1 'increment the prior count
        'output the record count
        wks.Cells(intRowCounter, 1).Value = intRecCounter

    Next itm
    
    bSuccess = True 'save the Excel file only if successful
    GoTo gracefulExit

ErrHandler:
    If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist", vbOKOnly, _
               "Error"
    Else
        MsgBox Err.Number & "; Description: ", vbOKOnly, _
               "Error"
    End If
    
gracefulExit:

    If Not wkb Is Nothing Then
        If bSuccess Then
            wkb.Close savechanges:=True
        Else
            wkb.Close savechanges:=False
        End If
        
        appExcel.Quit
    End If
    
    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing

End Sub

Open in new window


Cheers,

Dave
ASKER
daintysally

Hi Dave,

Thank you!!!!! :)  When I run the code, I get the following error:

438; Description

Can you tell me why?
Experts Exchange is like having an extremely knowledgeable team sitting and waiting for your call. Couldn't do my job half as well as I do without it!
James Murphy
ASKER
daintysally

Ok, I copied and pasted your code and instead of the 438 error, I get '9; Description'.

I changed the workbook name to delete all of the spaces out of it and now the 9 error is gone.  However, I am back to the 438 error
ASKER
daintysally

Should 'Set' be used here?

intRowCounter = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
dlmille

No - because we're getting data from the .Row property (not setting a range variable to a range object).

Set would be used on something like this:

dim rLastRow as Range

set rLastRow = wks.Cells(wks.Rows.Count,1).End(xlUp)   'this is setting range variable to a range object

Have you tried the code?

;)

Dave
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
ASKER
daintysally

Yes, I have tried the code, and I still get the error.
dlmille

Sorry, I only read your very last post.

Please comment out line 19: your on Error goto statement and then run it and advise what line you're getting the error on.
ASKER
daintysally

Ok, I commented out the on Error goto statement and the error is showing up here:

rng.Value = msg.Sender
All of life is about relationships, and EE has made a viirtual community a real community. It lifts everyone's boat
William Peck
dlmille

Ahhh... That helps.  It may not matter, but what version of Office/Outlook are you using?

Also, are you processing inboxes/saved emails or sent items?

Dave
ASKER CERTIFIED SOLUTION
dlmille

Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
See how we're fighting big data
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
ask a question
dlmille

Code reposted to ensure Outlook 2003 compatibility using .SenderName.

but be sure to change the strPath back to "C:\Desktop\"

;)

Cheers,

Dave
ASKER
daintysally

Ok, I am using outlook 2007 and I am pulling emails from another inbox that I have access to in the archived folder.  I am trying your changes now
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
ASKER
daintysally

msg.SenderName is not working
dlmille

What do you mean its not working?  can you provide more information?

PS - if you're using Outlook 2007, you can use .Sender

However, I really need to understand what you mean by not working.

Dave
ASKER
daintysally

Sorry for the haste, it works perfectly!!!  Thank you soooo much Dave!!!
This is the best money I have ever spent. I cannot not tell you how many times these folks have saved my bacon. I learn so much from the contributors.
rwheeler23
ASKER
daintysally

WONDERFUL!!! Dave is awesome!!