none
MS VBA for Outlook- extracting data from email to excel- errors in code? RRS feed

  • Question

  • I am getting an error on this line, however I am not sure why this is happening.

    Set xlSheet = xlWB.Sheets("data")

    +++

    I pasted this:

    Sub CopyToExcel()
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "C:\Users\tonya\My Documents\emails" 'the path of the workbook

    If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "No Items selected!", vbCritical, "Error"
    Exit Sub
    End If
    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")

    'Process each selected record
    For Each olItem In Application.ActiveExplorer.Selection
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
    rCount = xlSheet.UsedRange.Rows.Count
    rCount = rCount + 1

    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1
    If InStr(1, vText(i), "First Name:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("A" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Last Name:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("B" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Email Address:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("C" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Area of Interest:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("D" & rCount) = Trim(vItem(1))
    End If



    Next i
    xlWB.Save
    Next olItem
    xlWB.Close SaveChanges:=True
    If bXStarted Then
    xlApp.Quit
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    Set olItem = Nothing
    End Sub

    Monday, November 16, 2015 9:18 PM

All replies

  • Mr/s: Nu Hope Sales and Marketing

    strPath have not file name (name with extension)

    If you do not have file name, so you do not have sheet named "data" that's right?


    Oskar Shon, Office System MVP - www.VBATools.pl
    if Helpful; Answer when a problem solved

    Monday, November 16, 2015 11:09 PM
    Answerer
  • This looks like a variation of code I posted here some time ago.

    As Oscar has indicated your code includes a path, but not the filename of the workbook. You can either add the workbook name to the path or (with separator) to the open command. The  former is probably better (replace workbookname.xlsx with the name of your workbook.) :-

    Const strPath As String = "C:\Users\tonya\My Documents\emails\WorkbookName.xlsx" 'the path of the workbook
    Note also that workbook must exist. For an overview of the process see http://www.gmayor.com/extract_data_from_email.htm


    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, November 17, 2015 5:48 AM
  • i do have a file, I added a file extension and I do have a sheet named data. so this is why I am confused. Do I need to format the sheet? Now I am getting a "Macros in this project are disabled.... "

    Sub CopyToExcel()
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "C:\Users\tonya\My Documents\emails.xlsx" 'the path of the workbook

    If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "No Items selected!", vbCritical, "Error"
    Exit Sub
    End If
    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") <<<<< this line has a yellow arrow next to it and it's highlighted, sorry I am unable to post a screen shot at this time. 

    Tuesday, November 17, 2015 3:58 PM