Change 'copy email text into Word' to 'copy email text into Excel'

[ttratl]

Trying to find code to copy specific text from emails in a specific Outlook folder to Excel.

Found this code that works for me, but pastes my data into Word.
Is it possible to change it to paste into Excel? It's all a bit beyond my knowledge...

Option Explicit

'Create this macro in Word
'It requires a reference in vba tools > references
'to the Outlook object library e.g. for Outlook 2007
'Microsoft Outlook 12.0 object library

Sub ExtractOLMessage()
Dim sFname As String
Dim i As Long
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim olFolder As Outlook.Folder
Dim olItem As Outlook.MailItem
Dim oDoc As Document
Dim oTable As Table
Dim oRow As Row
Dim sText As String
Dim strName As String
Dim strLocation As String
Dim strDept As String
Dim bStarted As Boolean
Dim vText As Variant
Dim sDate As String
Dim sDay As String
Dim sMonth As String
Dim sYear As String

bStarted = False 'Set a flag

'Document containing the table
sFname = "E:\_Word stuff\MailTest\MailTest.docx"
'If the document is open, set it as the active document

If ActiveDocument.FullName = sFname Then
    Set oDoc = ActiveDocument
Else   'otherwise open it
    Set oDoc = Documents.Open(FileName:=sFname)
    bStarted = True 'And set the flag to true
End If
Set oTable = oDoc.Tables(1)
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err = 429 Then 'Outlook is closed so open it
    Set olApp = CreateObject("Outlook.Application")
End If
Set olNs = olApp.GetNamespace("MAPI")

'Indicate which Outlook folder to access
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("MailTest")

'Indicate the last message
Set olItem = olFolder.Items(olFolder.Items.Count)

'Get the text of the message
sText = olItem.Body

'and split it by paragraph
vText = Split(sText, Chr(13))

'and split it by colon (ASCII character 58)
'vText = Split(sText, Chr(58))

'Examine each paragraph
For i = 1 To UBound(vText)

    'and locate the text relating to the item required
    If InStr(1, vText(i), "be joining the company") Then

        'The Name we want is in the 1st paragraph so we add 0
        strName = vText(i + 0)

        'The Location we want is in the 3rd paragraph, so we add 3
        strLocation = vText(i + 3)
        
        'The Location we want is in the 5th paragraph, so we add 5
        strDept = vText(i + 5)

        'Log the date the message was sent
        sDate = Format(olItem.SentOn, "dd.MM.yyyy")

        'The entry has been found so stop looking for it
        Exit For
    End If
Next i

'Mark the message as read
olItem.UnRead = False

'Then clear the Outlook variables
Set olItem = Nothing
Set olItem = Nothing
Set olFolder = Nothing
Set olNs = Nothing
Set olApp = Nothing

'Add another row to the table
Set oRow = oTable.Rows.Add

'and fill the cells in that row with the extracted data
oRow.Cells(1).Range = sDate
oRow.Cells(2).Range = strName
oRow.Cells(2).Range = Replace(oRow.Cells(2).Range, Chr(13), "")
oRow.Cells(3).Range = strLocation
oRow.Cells(3).Range = Replace(oRow.Cells(3).Range, Chr(13), "")
oRow.Cells(4).Range = strDept
oRow.Cells(4).Range = Replace(oRow.Cells(4).Range, Chr(13), "")

'Establish whether the date is a Saturday or a Sunday (don't need this but not sure what to get rid of)
sMonth = MonthName(Mid(sDate, 4, 2))
sDay = Left(sDate, 2)
sYear = Right(sDate, 4)
sDate = sDay & Chr(32) & sMonth & Chr(32) & sYear
sDate = Weekday(sDate)
If sDate = 1 Or sDate = 7 Then 'it is a weekend
    'So colour the date cell

    oRow.Cells(1).Range.Shading.BackgroundPatternColor = -654245991
Else 'it is not a weekend so leave it white
    oRow.Cells(1).Range.Shading.BackgroundPatternColor = -603914241
End If
Application.ScreenRefresh

'this is my bit is to 'clean' the data in Word, to leave what I need:
    Selection.WholeStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "Location: "
        .Replacement.Text = ""

    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "Department: "
        .Replacement.Text = ""

    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = ", will be joining the company with effect from "
        .Replacement.Text = ""

    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "Further details are as follows:"
        .Replacement.Text = ""

    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^#^#-^?^?^?-^#^#."
        .Replacement.Text = "" 
'my 'cleaning' bit ends here


    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Collapse

If bStarted = True Then 'The document was opened by the macro so save it and close
    oDoc.Close SaveChanges:=wdSaveChanges
End If
Set oDoc = Nothing
End Sub

Any help appreciated

 

[JP2112]

Try this. You'll need to edit the three constants to reflect your code. There are other adaptations you'll need to make as well, if you want the code to be the same as the one you provided. See below for comments.

Sub ExportToExcel()
  On Error GoTo ErrorHandler
  Dim ol As Outlook.Application
  Dim olNS As Outlook.NameSpace
  Dim Folder As Outlook.MAPIFolder
  Dim msg As Outlook.MailItem
  Dim i As Long
  Dim exportInfo() As String
  Dim xl As Excel.Application
  Dim xlwkbk As Excel.Workbook
  Dim xlwksht As Excel.Worksheet
  Dim nextRow As Long
  Const numCols As Long = 2
  Const wkbkName As String = "filename.xls"
  Const filePath As String = "path to file"
  Set ol = Application
  Set olNS = ol.GetNamespace("MAPI")
  ' get folder to export
  Set Folder = olNS.PickFolder
  If Folder Is Nothing Then  ' nothing chosen
    GoTo ProgramExit
  End If
  If Folder.DefaultItemType <> olMailItem Or _
     Folder.Items.Count = 0 Then
    MsgBox "There are no mail messages to export"
    GoTo ProgramExit
  End If
  ' resize array
  ReDim exportInfo(1 To Folder.Items.Count, 1 To numCols)
  For i = 1 To Folder.Items.Count
    Set msg = Folder.Items.Item(i)
    exportInfo(i, 1) = msg.ReceivedTime
    exportInfo(i, 2) = msg.EntryID
  Next i
  ' grab Excel
  Set xl = GetExcelApp
  If xl Is Nothing Then
    MsgBox "Could not start Excel."
    GoTo ProgramExit
  End If
  ' create/open workbook
  If Len(Dir(filePath & wkbkName)) > 0 Then
    Set xlwkbk = xl.Workbooks.Open(filePath & wkbkName)
  Else
    Set xlwkbk = xl.Workbooks.Add
    xlwkbk.SaveAs (filePath & wkbkName)
  End If
 
  Set xlwksht = xlwkbk.Sheets(1)
  ' get next available row
  nextRow = xl.WorksheetFunction.CountA(xlwksht.Range("A:A")) + 1
  ' paste data into rows
  xl.Visible = True
  xlwksht.Cells(nextRow, 1).Resize(UBound(exportInfo), numCols).Value = exportInfo
 
ProgramExit:
  xl.Quit
  Set xlwksht = Nothing
  Set xlwkbk = Nothing
  Set xl = Nothing
  Exit Sub
ErrorHandler:
  MsgBox Err.number & " - " & Err.Description
  Resume ProgramExit
End Sub
 
Function GetExcelApp() As Excel.Application
  On Error Resume Next
  Set GetExcelApp = CreateObject("Excel.Application")
End Function

1. Replace "filename.xls" with the name of the file you want to create/update.
2. Replace "path to file" with the path of the spreadsheet.
3. Change "Const numCols As Long = 2" to reflect the number of pieces of information you want to extract from each email (sorry, I didn't go through your code to see what you wanted). For example if you are extracting 10 data points, the line should be "Const numCols As Long = 10"

Then you'll need to add to the For Loop as appropriate. For example if you wanted to extract three data points including the message subject, you would add

exportInfo(i, 3) = msg.Subject

And you would use "Const numCols As Long = 3" instead.

I use the PickFolder Method to choose the folder to export. That way you can use it on any folder. If you always use it on one folder only, you may want to hardcode the folder instead.

 

[ttratl]

Thanks for your help.
Got some problems though.
First error is a message saying "13-Type Mismatch". When I 'OK' that message another appears: "91 - Object variable or With block variable not set". This locks Excel. The only way out is cntrl/alt/del, and End Task.
I've never seen these messages before so no idea what they mean.

 

[JP2112]

The code should be run from Outlook. I included some early bound references by mistake, see corrected code below.

If you still get errors, I need to know which line is causing the error, as well as the error msg.

Sub ExportToExcel()
  On Error GoTo ErrorHandler
  Dim ol As Outlook.Application
  Dim olNS As Outlook.NameSpace
  Dim Folder As Outlook.MAPIFolder
  Dim msg As Outlook.MailItem
  Dim i As Long
  Dim exportInfo() As String
  Dim xl As Object ' Excel.Application
  Dim xlwkbk As Object ' Excel.Workbook
  Dim xlwksht As Object ' Excel.Worksheet
  Dim nextRow As Long
  Const numCols As Long = 2
  Const wkbkName As String = "filename.xls"
  Const filePath As String = "path to file"
  Set ol = Application
  Set olNS = ol.GetNamespace("MAPI")
  ' get folder to export
  Set Folder = olNS.PickFolder
  If Folder Is Nothing Then  ' nothing chosen
    GoTo ProgramExit
  End If
  If Folder.DefaultItemType <> olMailItem Or _
     Folder.Items.Count = 0 Then
    MsgBox "There are no mail messages to export"
    GoTo ProgramExit
  End If
  ' resize array
  ReDim exportInfo(1 To Folder.Items.Count, 1 To numCols)
  For i = 1 To Folder.Items.Count
    Set msg = Folder.Items.Item(i)
    exportInfo(i, 1) = msg.ReceivedTime
    exportInfo(i, 2) = msg.EntryID
  Next i
  ' grab Excel
  Set xl = GetExcelApp
  If xl Is Nothing Then
    MsgBox "Could not start Excel."
    GoTo ProgramExit
  End If
  ' create/open workbook
  If Len(Dir(filePath & wkbkName)) > 0 Then
    Set xlwkbk = xl.Workbooks.Open(filePath & wkbkName)
  Else
    Set xlwkbk = xl.Workbooks.Add
    xlwkbk.SaveAs (filePath & wkbkName)
  End If

  Set xlwksht = xlwkbk.Sheets(1)
  ' get next available row
  nextRow = xl.WorksheetFunction.CountA(xlwksht.Range("A:A")) + 1
  ' paste data into rows
  xl.Visible = True
  xlwksht.Cells(nextRow, 1).Resize(UBound(exportInfo), numCols).Value = exportInfo

ProgramExit:
  xl.Quit
  Set xlwksht = Nothing
  Set xlwkbk = Nothing
  Set xl = Nothing
  Exit Sub
ErrorHandler:
  MsgBox Err.number & " - " & Err.Description
  Resume ProgramExit
End Sub

Function GetExcelApp() As Object
  On Error Resume Next
  Set GetExcelApp = CreateObject("Excel.Application")
End Function

 

[ttratl]

Hey JP,

That works!
I guess i was being a bit dim - trying to run it from Excel. But it all runs perfectly from Outlook. I like the folder picker too as I have to look after 2 email accounts at work - so this is a good option for me.

Thanks very much, this is going to be very useful.

 

[JP2112]

Glad to hear it, enjoy!