none
PLEASE HELP: Export contents of Outlook 2007 email to Excel 2007 RRS feed

  • Question

  • Hello,

    I would be very grateful for someone's help with my specific question. Every month I receive over 1,000 emails that contain data that I currently have to manually copy and past into Excel. I automatically have the emails diverted to a folder in my Outlook and then every month I go in and paste the contents of each email into a spreadsheet.

    I would be very grateful if someone could help me with VBA code that will take the data from all of the emails and somehow? copy or export it to an excel file. The data in each email comes in the form of a table in the body of the email with the same 8 pieces of information (ie 8 colums with one heading each). Each line in the table represents a transaction and sometimes there will be multiple lines in one email (ie multiple transactions) and other times only one (ie one transaction). Is there a VBA code that can automatically extract the information from all of the emails that I have in this specific outlook folder and auto save it as an excel file??? I am hoping some VBA wizard out there can help me with this!!! :)

    Here is an example of how the data would appear. The headings are always the same, so I wouldnt need to extract those, just the contents under the headings.

    Date From To Amount Time ID# Method CRV
    1/1/2013 abc def 1000 1200 1234 ghi jkl
    1/2/2013 abc def 1 1400 1234 ghi jkl
    1/3/2013 abc def 999 2350 1234 ghi

    jkl

    Thanks,

    SHAUNA

    Monday, April 22, 2013 7:13 PM

Answers

  • The actual messages have a different column layout shown below,

     

    Trans # 1477

    ID#

    From

    To

    Method

    Date

    Time

    CRV

    Amount

    1234

    John Doe

    Jane Doe

    ---

    02/27/13

    0750

    ---

    101.00

    4567

    Jane Doe

    John Doe

    7549

    02/28/13

    1045

    5

    366.30

    QATS / brc

    so based on that the revised code would be as follows. This macro works on the currently selected message only and creates a new workbook for each month in the indicated folder. It would be a simple matter to change the code to work as a script or to loop through a collection of messages.

    Sub ExtractMessagetoExcel()
    Dim olItem As MailItem
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText() As String, vText2() As String, vData() As String
    Dim sText As String, sNewText As String
    Dim i As Long, j As Long, k As Long
    Dim iNextRow As Long
    Dim strWorkbookPath As String
    Dim strWorkbook As String
    Dim bXLStarted As Boolean
        strWorkbookPath = "D:\My Documents\Test\User Files\Test\"
        strWorkbook = strWorkbookPath & Format(Date, "MMM-YYYY") & "_Data.xlsx"

        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bXLStarted = True
        End If
        On Error GoTo 0
        'Open the workbook to input the data
        If Not FileExists(strWorkbook) Then
            Set xlWB = xlApp.workbooks.Add
            With xlWB.sheets(1)
                .Range("A1") = "ID#"
                .Range("B1") = "From"
                .Range("C1") = "To"
                .Range("D1") = "Method"
                .Range("E1") = "Date"
                .Range("F1") = "Time"
                .Range("G1") = "CRV"
                .Range("H1") = "Amount"
            End With
            xlWB.SaveAs strWorkbook
        Else
            Set xlWB = xlApp.workbooks.Open(strWorkbook)
        End If
        Set xlSheet = xlWB.sheets("Sheet1")

    Start:
        sNewText = ""
        Set olItem = Application.ActiveExplorer.Selection.Item(1)
        sText = Replace(olItem.Body, Chr(160), Chr(32))
        vText = Split(sText, Chr(13))
        For i = 0 To UBound(vText)
            If Len(vText(i)) > 1 Then
                sNewText = sNewText & vText(i) & "|"
            End If
        Next i

        vText = Split(sNewText, "|")
        For i = 0 To UBound(vText)
            If InStr(vText(i), "Amount") > 0 Then
                j = i
                Exit For
            End If
        Next i

        sNewText = ""
        For i = j + 1 To UBound(vText)
            sNewText = sNewText & Trim(vText(i)) & "|"
        Next i
        sNewText = Left(sNewText, Len(sNewText) - 1)
        vData = Split(sNewText, "|")
        For k = 0 To UBound(vData) Step 8
            If Not IsNumeric(vData(k)) Then Exit For
            iNextRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1
            With xlSheet
                .Range("A" & iNextRow) = Replace(vData(k), Chr(13), "")
                .Range("B" & iNextRow) = Replace(vData(k + 1), Chr(13), "")
                .Range("C" & iNextRow) = Replace(vData(k + 2), Chr(13), "")
                .Range("D" & iNextRow) = Replace(vData(k + 3), Chr(13), "")
                .Range("E" & iNextRow) = Replace(vData(k + 4), Chr(13), "")
                .Range("F" & iNextRow) = Replace(vData(k + 5), Chr(13), "")
                .Range("G" & iNextRow) = Replace(vData(k + 6), Chr(13), "")
                .Range("H" & iNextRow) = Replace(vData(k + 7), Chr(13), "")
                With .Range("A" & iNextRow & ":H" & iNextRow)
                    .HorizontalAlignment = -4131
                    .VerticalAlignment = -4160
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = -5002
                    .MergeCells = False
                    .ColumnWidth = 16
                End With
            End With
        Next k
        xlWB.Close 1
        If bXLStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
        Set olItem = Nothing
    End Sub

    Public Function FileExists(ByVal Filename As String) As Boolean
    Dim nAttr As Long
        On Error GoTo NoFile
        nAttr = GetAttr(Filename)
        If (nAttr And vbDirectory) <> vbDirectory Then
            FileExists = True
        End If
    NoFile:
    End Function


    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by insignia1234 Monday, April 29, 2013 10:47 PM
    • Unmarked as answer by insignia1234 Monday, April 29, 2013 10:47 PM
    • Marked as answer by insignia1234 Monday, April 29, 2013 10:48 PM
    Thursday, April 25, 2013 5:28 AM

All replies

  • Surely someone can help me solve this....I will give very positive feedback if a solution is determined!!!! :)
    Monday, April 22, 2013 10:04 PM
  • This is a duplicate of a question appended to another thread - see also my response there, but stick to this thread for follow up.

    In order to answer the question we need to know exactly how the incoming messages are formatted. The Excel format is of less relevance.


    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, April 23, 2013 5:40 AM
  • Hi Graham,

    I was hoping you would be able and willing to help as obviously you are very good at this stuff!!!! I saw how you had a similar code in another post, however I am unsure how to go about modifying it for my needs.

    In the previous post I put an example of what the email looks like when I receive it. I need to get the entries into Excel while at the same time excluding the first row of the email which are always the same as they are the headings. Below is an example of what the emails look like. In this example there are two rows, each representing a transaction, however some of the emails may have many more than just two rows of data (ie more than two transactions).

    Date   From    To   Amount      Time      ID#   Method      CRV
    1/1/2013    abc     def 1000 1200 1234      ghi       jkl
    1/2/2013    abc     def 1 1400 1234      ghi

          jkl

    Tuesday, April 23, 2013 1:10 PM
  • Ah! I had assumed that as how you wanted the worksheet to look and not the e-mail itself. It should be fairly simple to modify the other macro to achieve this. Do you want it to work automatically as the e-mails arrive, or do you want to do process the email or folder of e-mails manually

    Can you forward one of the e-mails to me at supportATgmayor.com (change AT for @)? I want to be certain exactly how it is formatted.


    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, April 23, 2013 1:43 PM
  • Well I would like all of the month's data in one file - it would be awesome if it could do it automatically, but is that possible? I am sorry but I am unable to forward an email as the messages are prevented from being forwarded. The data literally comes in the form of a table in the body of the email and what I do is copy + paste special as Text into Excel and it populates the cells just as it was laid out in the email.

    Are you still willing/able to help? Thanks Graham.

    SHAUNA

    Tuesday, April 23, 2013 11:24 PM
  • It should be possible to extract the data automatically as the messages arrive - presumably to a new file each month - but it is the splitting of the message to grab its components that is the tricky part without a sample of the message to work from. Tables in e-mail messages only serve to complicate the issue.

    Can you tell me what EXACTLY is on the next line that is not an empty paragraph immediately AFTER the table.

    If you cannot forward a message, can you post it as an attachment?

    Failing that can you paste ALL its content into a new message in the same format, so that you can change confidential information - if that is the problem.

    Without an accurate sample to work from it is going to be hit or miss.


    Graham Mayor - Word MVP
    www.gmayor.com

    Wednesday, April 24, 2013 5:12 AM
  • The following test may point a way forward without access to a message

    Select one of the messages (one with few entries!).

    Run the following macro and if all goes well, you should see several message boxes. The first will list the table contents each cell to a new line and the text that follows it. The remainder should display the dates from the first column in turn. If that works, let me know and we should be in business. If it doesn't work, let me know what appears instead.

    Sub Test()
    Dim olItem As Outlook.MailItem
    Dim vText() As String, vText2() As String, vData() As String
    Dim sText As String, sNewText As String
    Dim i As Long, j As Long, k As Long
    Start:
        sNewText = ""
        For Each olItem In Application.ActiveExplorer.Selection
            sText = Replace(olItem.Body, Chr(160), Chr(32))
            vText = Split(sText, Chr(13))
            For i = 0 To UBound(vText)
                If Len(vText(i)) > 1 Then
                    sNewText = sNewText & vText(i) & "|"
                End If
            Next i

            vText = Split(sNewText, "|")
            For i = 0 To UBound(vText)
                If InStr(vText(i), "CRV") > 0 Then
                    j = i
                    Exit For
                End If
            Next i

            sNewText = ""
            For i = j + 1 To UBound(vText)
                sNewText = sNewText & Trim(vText(i)) & "|"
            Next i
        Next olItem
        sNewText = Left(sNewText, Len(sNewText) - 1)
        MsgBox sNewText
        vData = Split(sNewText, "|")
        For k = 0 To UBound(vData) Step 8
            If Not IsDate(vData(k)) Then Exit For
            MsgBox vData(k)
        Next k
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com



    Wednesday, April 24, 2013 6:12 AM
  • The actual messages have a different column layout shown below,

     

    Trans # 1477

    ID#

    From

    To

    Method

    Date

    Time

    CRV

    Amount

    1234

    John Doe

    Jane Doe

    ---

    02/27/13

    0750

    ---

    101.00

    4567

    Jane Doe

    John Doe

    7549

    02/28/13

    1045

    5

    366.30

    QATS / brc

    so based on that the revised code would be as follows. This macro works on the currently selected message only and creates a new workbook for each month in the indicated folder. It would be a simple matter to change the code to work as a script or to loop through a collection of messages.

    Sub ExtractMessagetoExcel()
    Dim olItem As MailItem
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText() As String, vText2() As String, vData() As String
    Dim sText As String, sNewText As String
    Dim i As Long, j As Long, k As Long
    Dim iNextRow As Long
    Dim strWorkbookPath As String
    Dim strWorkbook As String
    Dim bXLStarted As Boolean
        strWorkbookPath = "D:\My Documents\Test\User Files\Test\"
        strWorkbook = strWorkbookPath & Format(Date, "MMM-YYYY") & "_Data.xlsx"

        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bXLStarted = True
        End If
        On Error GoTo 0
        'Open the workbook to input the data
        If Not FileExists(strWorkbook) Then
            Set xlWB = xlApp.workbooks.Add
            With xlWB.sheets(1)
                .Range("A1") = "ID#"
                .Range("B1") = "From"
                .Range("C1") = "To"
                .Range("D1") = "Method"
                .Range("E1") = "Date"
                .Range("F1") = "Time"
                .Range("G1") = "CRV"
                .Range("H1") = "Amount"
            End With
            xlWB.SaveAs strWorkbook
        Else
            Set xlWB = xlApp.workbooks.Open(strWorkbook)
        End If
        Set xlSheet = xlWB.sheets("Sheet1")

    Start:
        sNewText = ""
        Set olItem = Application.ActiveExplorer.Selection.Item(1)
        sText = Replace(olItem.Body, Chr(160), Chr(32))
        vText = Split(sText, Chr(13))
        For i = 0 To UBound(vText)
            If Len(vText(i)) > 1 Then
                sNewText = sNewText & vText(i) & "|"
            End If
        Next i

        vText = Split(sNewText, "|")
        For i = 0 To UBound(vText)
            If InStr(vText(i), "Amount") > 0 Then
                j = i
                Exit For
            End If
        Next i

        sNewText = ""
        For i = j + 1 To UBound(vText)
            sNewText = sNewText & Trim(vText(i)) & "|"
        Next i
        sNewText = Left(sNewText, Len(sNewText) - 1)
        vData = Split(sNewText, "|")
        For k = 0 To UBound(vData) Step 8
            If Not IsNumeric(vData(k)) Then Exit For
            iNextRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1
            With xlSheet
                .Range("A" & iNextRow) = Replace(vData(k), Chr(13), "")
                .Range("B" & iNextRow) = Replace(vData(k + 1), Chr(13), "")
                .Range("C" & iNextRow) = Replace(vData(k + 2), Chr(13), "")
                .Range("D" & iNextRow) = Replace(vData(k + 3), Chr(13), "")
                .Range("E" & iNextRow) = Replace(vData(k + 4), Chr(13), "")
                .Range("F" & iNextRow) = Replace(vData(k + 5), Chr(13), "")
                .Range("G" & iNextRow) = Replace(vData(k + 6), Chr(13), "")
                .Range("H" & iNextRow) = Replace(vData(k + 7), Chr(13), "")
                With .Range("A" & iNextRow & ":H" & iNextRow)
                    .HorizontalAlignment = -4131
                    .VerticalAlignment = -4160
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = -5002
                    .MergeCells = False
                    .ColumnWidth = 16
                End With
            End With
        Next k
        xlWB.Close 1
        If bXLStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
        Set olItem = Nothing
    End Sub

    Public Function FileExists(ByVal Filename As String) As Boolean
    Dim nAttr As Long
        On Error GoTo NoFile
        nAttr = GetAttr(Filename)
        If (nAttr And vbDirectory) <> vbDirectory Then
            FileExists = True
        End If
    NoFile:
    End Function


    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by insignia1234 Monday, April 29, 2013 10:47 PM
    • Unmarked as answer by insignia1234 Monday, April 29, 2013 10:47 PM
    • Marked as answer by insignia1234 Monday, April 29, 2013 10:48 PM
    Thursday, April 25, 2013 5:28 AM