none
VBA Code for transferring data from email in Outlook to a spreadsheet in Excel RRS feed

  • Question

  • I'm not computer savvy, and I've been here before for help with a similar issue. Please, see the info below and help me if you can... Thanks!

    I have client emails being sent to my Outlook as follows:

    Ship Date: 07/01/2012

     

    CONTACT INFORMATION

     

    Name: BLAH

     

    Email Address: BLAH@BLAH.COM

     

    Phone: 9999999999

     

    VEHICLE INFORMATION

     

    Year: 2008

     

    Make: Honda

     

    Model: Civic

     

     

    PICKUP AND DELIVERY INFORMATION

     

    Pickup City: EDISON

     

    Pickup State: NJ

     

    Pickup Zipcode: 08837

     

    Delivery City: NOVATO

     

    Delivery State: CA

     

    Delivery Zipcode: 90009

    The thing is, I only need a few of the items to be parsed over to my Excel worksheet. I have to keep all the information organized in columns, and I eliminated the information I don't need parsed. I have also changed the names to match what the name of the columns are in Excel:

    Name: BLAH

     

    Email Address: BLAH@BLAH.COM

     

    Phone: 9999999999

     

    Year: 2008

     

    Make: Honda

     

    Model: Civic

     

    P:Zip: 08837

     

    D:Zip: 90009

    If someone can just make a code I can copy and paste into my VBA on Outlook, I would really appreciate it... I don't know how to do anything more than create a new VBA. THANKS!!!!!

    Tuesday, June 19, 2012 10:50 PM

Answers

  • It's like deja vu all over again. I have answered this in a previous thread - and that answer only needs minor modification to accommodate the more limited range of pieces to extract. The following macro puts the data in columns A through H. If you want it in different columns change the letters to reflect the columns you require in the lines similar to xlSheet.Range("A" & rCount) = Trim(vItem(1))

    Sub CopyToExcel()
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim oRng As Range
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "D:\My Documents\Vehicles.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("Sheet1")

    '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.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
        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), "Name:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If

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

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

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

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

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

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

            If InStr(1, vText(i), "Delivery Zipcode:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("H" & 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


    Graham Mayor - Word MVP
    www.gmayor.com




    • Marked as answer by patllc Sunday, July 22, 2012 6:35 PM
    • Edited by Graham MayorMVP Monday, July 23, 2012 12:28 PM
    Sunday, July 22, 2012 1:04 PM
  • You would locate the segment

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

    in the larger macro listing from my earlier message and replace it with

            If InStr(1, vText(i), "Email Address:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                sAddr = ""
                For j = 1 To UBound(vItem)
                    sAddr = sAddr & vItem(j)
                Next j
                If InStr(1, UCase(sAddr), "HYPERLINK") > 0 Then
                    vAddr = Split(sAddr, Chr(34))
                    sAddr = vAddr(UBound(vAddr))
                End If
                xlSheet.Range("B" & rCount) = sAddr
            End If

    This should resolve the e-mail address whether it is plain text or in the form  of a hyperlink.You should add the two variable declarations

    Dim sAddr as String
    Dim j as Long

    at the top of the module with the other declarations

    and I forgot to include

    Dim vAddr as Variant

    which should also be included with the others.


    Graham Mayor - Word MVP
    www.gmayor.com


    • Edited by Graham MayorMVP Monday, July 23, 2012 2:19 PM
    • Marked as answer by patllc Monday, July 23, 2012 2:23 PM
    Monday, July 23, 2012 2:18 PM

All replies

  • That template is a simple to cut and transfer to Excel cells.

    Take look on that: Automatyzacja 2 - Wyszukanie danych w wiadomości Outlooka i dopisanie do pliku aplikacji Excel

    You must search specify text/string and after split copy to excels worksheet row.


    Oskar Shon, Office System MVP

    Press if Helpful; Answer when a problem solved

    Saturday, July 21, 2012 7:05 PM
    Answerer
  • It's like deja vu all over again. I have answered this in a previous thread - and that answer only needs minor modification to accommodate the more limited range of pieces to extract. The following macro puts the data in columns A through H. If you want it in different columns change the letters to reflect the columns you require in the lines similar to xlSheet.Range("A" & rCount) = Trim(vItem(1))

    Sub CopyToExcel()
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim oRng As Range
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "D:\My Documents\Vehicles.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("Sheet1")

    '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.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
        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), "Name:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If

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

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

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

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

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

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

            If InStr(1, vText(i), "Delivery Zipcode:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("H" & 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


    Graham Mayor - Word MVP
    www.gmayor.com




    • Marked as answer by patllc Sunday, July 22, 2012 6:35 PM
    • Edited by Graham MayorMVP Monday, July 23, 2012 12:28 PM
    Sunday, July 22, 2012 1:04 PM
  • Will this work with forwarded emails and emails with other text?


    WJM

    Sunday, July 22, 2012 6:38 PM
  • what if one of the fields is a hyperlink... say the "email" is emailed as a hyperlink or javascript, how can I parse the actual text?

    Thanks so much!!!


    WJM

    Sunday, July 22, 2012 7:41 PM
  • The macro will work with the text displayed on screen. If you want it to work with something else, you need to let us know exactly what that is.

    The macro simply looks at each paragraph of the selected message(s) and splits it at the colon. It then grabs the part to the right of the colon, strips leading and trailing spaces and writes it to the named cell.

    If you have something else to handle then either send me a sample or post a sample somewhere e.g. SkyDrive or DropBox,  so that we can download it.


    Graham Mayor - Word MVP
    www.gmayor.com

    Monday, July 23, 2012 4:48 AM
  • On further reflection what I think you mean relates to

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

    Add

    Dim aAddr as String
    Dim j as Long

    with the declarations at the start and then change the above section to

            If InStr(1, vText(i), "Email Address:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                sAddr = ""
                For j = 1 To UBound(vItem)
                    sAddr = sAddr & vItem(j)
                Next j
                If InStr(1, UCase(sAddr), "HYPERLINK") > 0 Then
                    vAddr = Split(sAddr, Chr(34))
                    sAddr = vAddr(UBound(vAddr))
                End If
                xlSheet.Range("B" & rCount) = sAddr
            End If


    Graham Mayor - Word MVP
    www.gmayor.com


    Monday, July 23, 2012 12:27 PM
  • So, would I then copy and paste the code above into a new module or somewhere in the middle of the first module?

    Thanks


    WJM

    Monday, July 23, 2012 1:58 PM
  • You would locate the segment

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

    in the larger macro listing from my earlier message and replace it with

            If InStr(1, vText(i), "Email Address:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                sAddr = ""
                For j = 1 To UBound(vItem)
                    sAddr = sAddr & vItem(j)
                Next j
                If InStr(1, UCase(sAddr), "HYPERLINK") > 0 Then
                    vAddr = Split(sAddr, Chr(34))
                    sAddr = vAddr(UBound(vAddr))
                End If
                xlSheet.Range("B" & rCount) = sAddr
            End If

    This should resolve the e-mail address whether it is plain text or in the form  of a hyperlink.You should add the two variable declarations

    Dim sAddr as String
    Dim j as Long

    at the top of the module with the other declarations

    and I forgot to include

    Dim vAddr as Variant

    which should also be included with the others.


    Graham Mayor - Word MVP
    www.gmayor.com


    • Edited by Graham MayorMVP Monday, July 23, 2012 2:19 PM
    • Marked as answer by patllc Monday, July 23, 2012 2:23 PM
    Monday, July 23, 2012 2:18 PM
  • Fantastic!!!

    This is exactly what I needed!

    Thanks so much for your help Graham, and if you ever need to get a car shipped, I will discount you $100!

    -PlymouthAutoTransport.com


    WJM

    Monday, July 23, 2012 2:24 PM
  • If you move vehicles around Europe I may take you up on that :)

    Graham Mayor - Word MVP
    www.gmayor.com

    Monday, July 23, 2012 2:57 PM
  • Not licensed there, however, if you ever want to buy an old American classic automobile and ship it to Europe, then I will get it to the port for you... maybe one day I will be licensed in Europe ;)

    WJM

    Monday, July 23, 2012 3:11 PM
  • Thanks for your help, but there's a problem. I receive a few other formats of the same emailed sales lead, and the code you gave me doesn't work on all of them I found out :) told you I'm not computer literate!

    Anyway, here's another example of an email I receive:

    first_name: NAME

    last_name: NAME

    phone: 123-456-7890

    email: NAMENAME@NAME.COM

    pickup_city: warwick

    pickup_state_code: RI

    pickup_zip: 02886

    pickup_country_id: 1

    dropoff_city:los angeles

    dropoff_state_code: CA

    dropoff_zip: 91204

    dropoff_country_id: 1

    estimated_ship_date: 08/10/2012

    vehicle_runs: Yes

    ship_via_id: Open

    year1: 2002

    make1: volvo

    model1: s80

    vehicle_type_id1: Sedan Midsize

    vehicle_type_other1: [vehicle_type_other1]

    customer_comment: [customer_comment]

    And, I need the following parsed:

    first_name: NAME

    phone: 123-456-7890

    email: NAMENAME@NAME.COM

    pickup_city: warwick

    pickup_state_code: RI

    pickup_zip: 02886

    dropoff_city:los angeles

    dropoff_state_code: CA

    dropoff_zip: 91204

    estimated_ship_date: 08/10/2012

    vehicle_runs: Yes

    year1: 2002

    make1: volvo

    model1: s80

    vehicle_type_id1: Sedan Midsize

    customer_comment: [customer_comment]

    Thanks so much for all you've done so far, and I will let you know once we expand into the European market :)

    Sincerely,


    WJM



    • Edited by patllc Monday, July 30, 2012 3:19 PM
    Monday, July 30, 2012 3:18 PM
  • You certainly picked a complicated place to start learning VBA. I have been doing this for a while and I still find Outlook VBA difficult:)

    I will contact you via e-mail.


    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, July 31, 2012 3:57 AM