Solved

Extracting data from Outlook and populate a spreadsheet (Excel 2007)

Posted on 2011-03-21
35
686 Views
Last Modified: 2012-05-11
I need to extract the data that comes in an email in the below format.
The capitalized text would be the column header and the data
following the colon comprises the rows. Not always is there a colon
seperating the two or the line of dashes separating the entries.
Every entry needs to populate a row.

The email comes in under support@sovereigngoldcard.com and then in the Inbox.
It is a gmail account if that matters.

MTCN#:056-026-1234
RECEIVER:  Beata Pellei
SENDER: Brett Degan
SENDER LOCATION: West Babylon, NY
AMT: $940
-------------------
MTCN:729-184-4546
RECEIVER:  Beata Pellei
SENDER: Brett Degan
SENDER LOCATION: West Babylon, NY
AMT: $940
-------------------
MTCN: 161-427-7890
RECEIVER:  Beata Pellei
SENDER: Chris Bambino
SENDER LOCATION: West Islip, NY
AMT: $940
--------------------
Mtcn: 964-213-2222
Receiver: Beata Pellei
Sender: jeff Schmidt
Sender location: Henderson, Nevada
Amount:$520
0
Comment
Question by:JaseS
  • 18
  • 17
35 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35186767
Potentially doable BUT we do need a clear pattern:

1. The column heading is not always capitlised
2. The column heading is not always the same text
3. The colon is not always there, (your words)

We can lock onto the key words but if anything changes, (amount/amt for example) the code would need changing.

How do you want to run the code ... i.e. how will you trigger the code against an email and what version of outlook / excel.

Chris
0
 

Author Comment

by:JaseS
ID: 35188716
1. Not always capitalized
2. The spreadsheet that the email gets imported into will always have the following headers:
MTCN, Receiver, Sender, Sender location, amount, but the email's 'headers' will vary sometimes.
3.. For the vast majority of emails I get, I'm going to change what I initially said. YES there IS always a colon seperating

So, let's go on the premise that the constant you can work with is there be a colon seperating the headers (which do NOT get imported to the spreadsheet) and the data (which DOES get imported to the spreadsheet. To make it clear, each import or run of the code updates one spreadsheet which has the headers already at the top. It does not create a new sheet with each import.

Run code by a button on the spreadsheet the data gets imported into.
Outlook and Excel 2007.

0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35188746
The workbook will be contained in a mail and when opened you will have a button on the worksheet to run code we supply on the active mail?

Is that right?

Chris
0
 

Author Comment

by:JaseS
ID: 35190173
No. The workbook is not in the email. I will have it on my desktop. I click the button on the spreadsheet that contains the headers. The code within the spreadsheet will access my Outlook folder, Inbox, scrub it and bring in the data and paste it under the appropriate column headers
0
 

Author Comment

by:JaseS
ID: 35198174
Hi Chris,

Do you think this is something you can do?
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35198876
Apologies did post but have had some issues lately.

Short answer yes but would ask if the code runs from the workbook ... how are mails identified .. all mails with the addressee and structure or for example only those selected?

Chris
0
 

Author Comment

by:JaseS
ID: 35199022
code runs from workbook by clicking a button on the sheet the data is to be imported to

emails are only identified by body of text mentioned as above:
MTCN#:056-026-1234
RECEIVER:  Beata Pellei
SENDER: Brett Degan
SENDER LOCATION: West Babylon, NY
AMT: $940

Cannot be indentified by subject of email.
Not sure what you are asking with the last part of your question
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35201517
Understood re body:

Last bit is what is the intention of the button ... run it on all of the mails in the inbox, (where the body matches)?

Extending that aspect though, does an email 'match' if any of the 'fields' exist or do they all need to exist?

Chris
0
 

Author Comment

by:JaseS
ID: 35201779
Yes, to run it on all th emails in the Inbox where the body matches. It for sure will have the word MTCN in the body. Email matches if any of the fields exist, but best to run it off of 'MTCN', capitalized or not.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35201942
Okay I have what I need, please note depending on the number of emails it may take a while to run since we cannot filter on the body to reduce the collection.  Not a problem ... just making a note.

Chris
0
 

Author Comment

by:JaseS
ID: 35202267
there won't be more than a few, maybe ten at most, emails. I clear out my inbox often. Thanks.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35202269
Working on it but more questions:

1. is there only one email which will have the entry?
2. Is it reasonable to look for the latest emails in order to speed it up.
3. Does an email have more than one set of data as in your initial post?

Chris
0
 

Author Comment

by:JaseS
ID: 35202291
no, more than one email per day - maybe as many as three in my inbox

yes, but it could be an email a few days in my inbox

yes, could have ten or more sets
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35202825
Try the following.

Chris
Sub Q_26900870()
Dim mai As Object
Dim olkApp As Object
Dim folderItems As Variant
Dim sortedItems As Variant
Dim rng As Range
Dim arrRows() As String
Dim arrRow() As String
Dim elem As Variant
Const olFolderinbox As Integer = 6
Const olMail As Integer = 43
    
    Set olkApp = CreateObject("outlook.application")
    Set folderItems = olkApp.Session.GetDefaultFolder(olFolderinbox).items
    folderItems.Sort "receivedtime", True
    Set sortedItems = folderItems

    For Each mai In sortedItems
        If mai.Class = olMail Then
            If InStr(1, mai.body, "MTCN", vbTextCompare) > 0 Then
                Set rng = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                arrRows = Split(mai.body, vbCrLf, , vbTextCompare)
                For Each elem In arrRows
                    If Left(elem, 1) = "-" Then
                        Set rng = rng.Offset(1, 0)
                    Else
                        arrRow = Split(elem, ":")
                        Select Case UCase(arrRow(0))
                            Case "MTCN", "MTCN#"
                                rng = arrRow(1)
                            Case "RECEIVER"
                                rng.Offset(0, 1) = arrRow(1)
                            Case "SENDER"
                                rng.Offset(0, 2) = arrRow(1)
                            Case "SENDER LOCATION"
                                rng.Offset(0, 3) = arrRow(1)
                            Case "AMOUNT", "AMT"
                                rng.Offset(0, 4) = arrRow(1)
                            Case Else
                        End Select
                    End If
                Next
            End If
        End If
    Next
    rng.Parent.Range("A1:E1").EntireColumn.AutoFit
End Sub

Open in new window

0
 

Author Comment

by:JaseS
ID: 35203112
Hi Chris,

Created button, put it on a sheet in my workbook, put code in, clicked the button and nothing happened, no error messages, nothing. Do I need to have the column headings already in place on the worksheet?

Maybe it's not accessing my inbox. Attached is a screenshot of the folder layout in my Outlook structure. Outlook Screenshot
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35204739
Added the implied request for the header row, the script addresses all mails in the default inbox.  It looks however as though you want to address the support PST?

support@sovereigngoldcard.com

Chris
Sub Q_26900870()
Dim mai As Object
Dim olkApp As Object
Dim folderItems As Variant
Dim sortedItems As Variant
Dim rng As Range
Dim arrRows() As String
Dim arrRow() As String
Dim elem As Variant
Const olFolderinbox As Integer = 6
Const olMail As Integer = 43
    
    Set olkApp = CreateObject("outlook.application")
    Set folderItems = olkApp.Session.folders("support@sovereigngoldcard.com").folders("inbox").items
    folderItems.Sort "receivedtime", True
    Set sortedItems = folderItems
    
    ThisWorkbook.Sheets(1).Range("A1:E1") = Array("MCTN", "Receiver", "Sender", "Sender Location", "Amount")
    For Each mai In sortedItems
        If mai.Class = olMail Then
            If InStr(1, mai.body, "MTCN", vbTextCompare) > 0 Then
                Set rng = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                arrRows = Split(mai.body, vbCrLf, , vbTextCompare)
                For Each elem In arrRows
                    If Left(elem, 1) = "-" Then
                        Set rng = rng.Offset(1, 0)
                    Else
                        arrRow = Split(elem, ":")
                        Select Case UCase(arrRow(0))
                            Case "MTCN", "MTCN#"
                                rng = arrRow(1)
                            Case "RECEIVER"
                                rng.Offset(0, 1) = arrRow(1)
                            Case "SENDER"
                                rng.Offset(0, 2) = arrRow(1)
                            Case "SENDER LOCATION"
                                rng.Offset(0, 3) = arrRow(1)
                            Case "AMOUNT", "AMT"
                                rng.Offset(0, 4) = arrRow(1)
                            Case Else
                        End Select
                    End If
                Next
            End If
        End If
    Next
    rng.Parent.Range("A1:E1").EntireColumn.AutoFit
End Sub

Open in new window

0
 

Author Comment

by:JaseS
ID: 35207537
This time code ran but came back with an error:
Run time error '9'

And when look at code, 'Select Case UCase (arrRow(0)) is higlighted in yellow.
0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35208569
Suggests an email with only the MCTN line, or line feeds without carriage return:

Hopefully this change avoids that.

Chris
Sub Q_26900870()
Dim mai As Object
Dim olkApp As Object
Dim folderItems As Variant
Dim sortedItems As Variant
Dim rng As Range
Dim arrRows() As String
Dim arrRow() As String
Dim elem As Variant
dim strBodyText as string
Const olFolderinbox As Integer = 6
Const olMail As Integer = 43
    
    Set olkApp = CreateObject("outlook.application")
    Set folderItems = olkApp.Session.folders("support@sovereigngoldcard.com").folders("inbox").items
    folderItems.Sort "receivedtime", True
    Set sortedItems = folderItems
    
    ThisWorkbook.Sheets(1).Range("A1:E1") = Array("MCTN", "Receiver", "Sender", "Sender Location", "Amount")
    For Each mai In sortedItems
        If mai.Class = olMail Then
            strbodytext = mai.body
            strbodytext = replace(strbodytext, vbcrlf, "$###$")
            strbodytext = replace(strbodytext, vblf, vbcrlf)
            strbodytext = replace(strbodytext, "$###$", vbcrlf)
            If InStr(1, mai.body, "MTCN", vbTextCompare) > 0 and InStr(mai.body, vbcrlf) > 0 Then
                Set rng = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                arrRows = Split(mai.body, vbCrLf, , vbTextCompare)
                For Each elem In arrRows
                    If Left(elem, 1) = "-" Then
                        Set rng = rng.Offset(1, 0)
                    Else
                        arrRow = Split(elem, ":")
                        Select Case UCase(arrRow(0))
                            Case "MTCN", "MTCN#"
                                rng = arrRow(1)
                            Case "RECEIVER"
                                rng.Offset(0, 1) = arrRow(1)
                            Case "SENDER"
                                rng.Offset(0, 2) = arrRow(1)
                            Case "SENDER LOCATION"
                                rng.Offset(0, 3) = arrRow(1)
                            Case "AMOUNT", "AMT"
                                rng.Offset(0, 4) = arrRow(1)
                            Case Else
                        End Select
                    End If
                Next
            End If
        End If
    Next
    rng.Parent.Range("A1:E1").EntireColumn.AutoFit
End Sub

Open in new window

0
 

Author Comment

by:JaseS
ID: 35208727
same exact results - error 9 with same code line yellowed.

Do I need column headers in the sheet prior to running the code? Not sure if that is a problem or not.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35208920
Column Headers already taken care of in the code.  I'm running in 2010 so let's try a force on the data type:

Note the code works for me in my tests hence trying to see what is different in your case.  I have also changed the sort order so if it's mail specific we will hopefully get another mail running first so as a clue to the issue.

Also make sure the mails are not encrypted or signed.

Chris
Sub Q_26900870()
Dim mai As Object
Dim olkApp As Object
Dim folderItems As Variant
Dim sortedItems As Variant
Dim rng As Range
Dim arrRows() As String
Dim arrRow() As String
Dim elem As Variant
Const olFolderinbox As Integer = 6
Const olMail As Integer = 43
    
    Set olkApp = CreateObject("outlook.application")
    Set folderItems = olkApp.Session.folders("support@sovereigngoldcard.com").folders("inbox").items
    folderItems.Sort "receivedtime", false
    Set sortedItems = folderItems
    
    ThisWorkbook.Sheets(1).Range("A1:E1") = Array("MCTN", "Receiver", "Sender", "Sender Location", "Amount")
    For Each mai In sortedItems
        If mai.Class = olMail Then
            If InStr(1, mai.body, "MTCN", vbTextCompare) > 0 Then
                Set rng = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                arrRows = Split(mai.body, vbCrLf, , vbTextCompare)
                For Each elem In arrRows
                    If Left(elem, 1) = "-" Then
                        Set rng = rng.Offset(1, 0)
                    Else
                        arrRow = Split(elem, ":")
                        Select Case UCase(cstr(arrRow(0)))
                            Case "MTCN", "MTCN#"
                                rng = arrRow(1)
                            Case "RECEIVER"
                                rng.Offset(0, 1) = arrRow(1)
                            Case "SENDER"
                                rng.Offset(0, 2) = arrRow(1)
                            Case "SENDER LOCATION"
                                rng.Offset(0, 3) = arrRow(1)
                            Case "AMOUNT", "AMT"
                                rng.Offset(0, 4) = arrRow(1)
                            Case Else
                        End Select
                    End If
                Next
            End If
        End If
    Next
    rng.Parent.Range("A1:E1").EntireColumn.AutoFit
End Sub

Open in new window

0
 

Author Comment

by:JaseS
ID: 35209092
hmmmm....

same exact results

Encrypted? no
Signed? not sure what you mean by that.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35209362
Lets see if it's a blank line ...

Chris
Sub Q_26900870()
Dim mai As Object
Dim olkApp As Object
Dim folderItems As Variant
Dim sortedItems As Variant
Dim rng As Range
Dim arrRows() As String
Dim arrRow() As String
Dim elem As Variant
Const olFolderinbox As Integer = 6
Const olMail As Integer = 43
    
    Set olkApp = CreateObject("outlook.application")
    Set folderItems = olkApp.Session.Folders("support@sovereigngoldcard.com").Folders("inbox").items
    folderItems.Sort "receivedtime", False
    Set sortedItems = folderItems
    
    ThisWorkbook.Sheets(1).Range("A1:E1") = Array("MCTN", "Receiver", "Sender", "Sender Location", "Amount")
    For Each mai In sortedItems
        If mai.Class = olMail Then
            If InStr(1, mai.body, "MTCN", vbTextCompare) > 0 Then
                Set rng = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                arrRows = Split(mai.body, vbCrLf, , vbTextCompare)
                For Each elem In arrRows
                    If Left(elem, 1) = "-" Then
                        Set rng = rng.Offset(1, 0)
                    Else
                        If InStr(elem, ":") > 0 Then
                            arrRow = Split(elem, ":")
                            Select Case UCase(CStr(arrRow(0)))
                                Case "MTCN", "MTCN#"
                                    rng = arrRow(1)
                                Case "RECEIVER"
                                    rng.Offset(0, 1) = arrRow(1)
                                Case "SENDER"
                                    rng.Offset(0, 2) = arrRow(1)
                                Case "SENDER LOCATION"
                                    rng.Offset(0, 3) = arrRow(1)
                                Case "AMOUNT", "AMT"
                                    rng.Offset(0, 4) = arrRow(1)
                                Case Else
                            End Select
                        End If
                    End If
                Next
            End If
        End If
    Next
    rng.Parent.Range("A1:E1").EntireColumn.AutoFit
End Sub

Open in new window

0
 

Author Comment

by:JaseS
ID: 35210240
well, no error but nothing else happens. the cursor twirls like it's doing something but nothing comes out of it.

I don't know if it will help, but attached a screenshot of my Outlook app, and an actual email coming in that I need imported to a spreadsheet. (some numbers smudged for security sake) email screenshot
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35210349
As it stands the output is going to sheet 1 have you checked there?

Chris
0
 

Author Comment

by:JaseS
ID: 35210507
Ok, there we go! I was using it in a workbook and Sheet 1 was not at the beginning. Now it is and it imports data, just not all of it: take a look. And that is being pulled from this email:

MTCN#: 069-840-xxxx
RECEIVER: BEATA PELLEI
SENDER: BRANDON HESxxxx
SENDER'S W.U. LOCATION: Springfield, Ohio
AMOUNT:645
-----------------------
MTCN#: 156-593-xxxx
RECEIVER: BEATA PELLEI
SENDER: PETER Rxxxx
SENDER'S W.U. LOCATION: HALLANDALE BEACH FLA 33009
AMOUNT: 520.00
-----------------------
MTCN#: 157-519-xxxx
RECEIVER:  BEATA  PELLEI
SENDER:  JEFFREY BRxxxx
SENDER'S W.U. LOCATION : Virginia Beach,  VA.
AMOUNT:  1,985.00
-------------------------
MTCN#:860353xxxx
RECEIVER: Beata Pellei
Sender: Tom Derrxxxx
Location: Manhattan , ny.
Amount: 900.00
--------------------------
MTCN#:156-293-xxxx
RECEIVER:beata pellei
SENDER: david temxxx
SENDER LOCATION: baton rouge la
AMT: $2,455.00
--------------------------
MTCN#: 505-960-xxxx
RECEIVER: BEATA  PELLEI
SENDER: JEFFREY  BRxxx
SENDER'S W.U. LOCATION: VIRGINIA BEACH,  VA
AMOUNT: 1,935.00
-------------------------

 output
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35210612
Have to establish all the permutations ... these things are not easy when you do not have 'standards' in respect of data structure.  I have modified to allow for the sender location string variations.

Chris
Sub Q_26900870()
Dim mai As Object
Dim olkApp As Object
Dim folderItems As Variant
Dim sortedItems As Variant
Dim rng As Range
Dim arrRows() As String
Dim arrRow() As String
Dim elem As Variant
Const olFolderinbox As Integer = 6
Const olMail As Integer = 43
    
    Set olkApp = CreateObject("outlook.application")
    Set folderItems = olkApp.Session.Folders("support@sovereigngoldcard.com").Folders("inbox").items
    folderItems.Sort "receivedtime", False
    Set sortedItems = folderItems
    
    ThisWorkbook.Sheets(1).Range("A1:E1") = Array("MCTN", "Receiver", "Sender", "Sender Location", "Amount")
    For Each mai In sortedItems
        If mai.Class = olMail Then
            If InStr(1, mai.body, "MTCN", vbTextCompare) > 0 Then
                Set rng = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                arrRows = Split(mai.body, vbCrLf, , vbTextCompare)
                For Each elem In arrRows
                    If Left(elem, 1) = "-" Then
                        Set rng = rng.Offset(1, 0)
                    Else
                        If InStr(elem, ":") > 0 Then
                            arrRow = Split(elem, ":")
                            Select Case trim(UCase(CStr(arrRow(0))))
                                Case "MTCN", "MTCN#"
                                    rng = arrRow(1)
                                Case "RECEIVER"
                                    rng.Offset(0, 1) = arrRow(1)
                                Case "SENDER"
                                    rng.Offset(0, 2) = arrRow(1)
                                Case "SENDER LOCATION", "LOCATION", "SENDER'S W.U. LOCATION"
                                    rng.Offset(0, 3) = arrRow(1)
                                Case "AMOUNT", "AMT"
                                    rng.Offset(0, 4) = arrRow(1)
                                Case Else
                            End Select
                        End If
                    End If
                Next
            End If
        End If
    Next
    rng.Parent.Range("A1:E1").EntireColumn.AutoFit
End Sub

Open in new window

0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35210640
If there are other datums that are missing then add the string as upper case to the structure.  For example to modify the sender location variation I changed:


Case "SENDER LOCATION"
to
Case "SENDER LOCATION", "LOCATION", "SENDER'S W.U. LOCATION"

Use a similar approach for any different key strings before the colon for other datums, but remember CAPITALS!.

Chris
0
 

Author Comment

by:JaseS
ID: 35210668
almost. see attached. It is missing some data yet from the last entries on the email:

-------------------------
MTCN# 831-802-3xxxx
RECEIVER: BEATA PELLEI
SENDER: TOM ARMxxxx
SENDER LOCATION: GRAND PRAIRIE, TX 75050
AMT: $1040
----------------------
MTCN#: 335-469-6xxx
RECEIVER: BEATA PELLEI
SENDER: JAMES CORxxxx
SENDER'S W.U. LOCATION: MANCHESTER, VT - USA
AMOUNT: $505
----------------------
MTCN#: 591-279-9xxx
RECEIVER:BEATA PELLEI
SENDER: ALLAN MODRZExxx
SENDER'S W.U. LOCATION: WAUSAU, WISCONSIN
AMOUNT: $705.00
------------------------
MTCN#:4741065xxx
RECEIVER: BEATA PELLEI
SENDER: FERNANDO INxxxx
SENDER'S W.U. LOCATION(city & state): SAN DIEGO, CALIFORNIA
AMOUNT: $675
-----------------------
mtcn#0909176xxx
receiver: Beata Pellei
Sender mike Joxxx
sender location; Coeur d'alene Idaho
$575.00
-------------------------
MTCN 496-273-xxxx
Receiver: Beata Pellei
sender: Robert Lanxxx
Sender location: Bolingbrook IL
amt: $1310
-------------------------
 output 2
0
 

Author Comment

by:JaseS
ID: 35210706
and is it possible to have the order of the columns be in this order?

Receiver - date email received - MTCN - Sender - Sender Location - Amount

If too much to put in date email received, then at least in this order with a blank column between Receiver and MTCN#

Possible?
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35210938
In one case there is no colon i.e. we started out on the understanding colons do exist.

In another then like I said you can add the change detail yourself i.e.


Case "SENDER LOCATION", "LOCATION", "SENDER'S W.U. LOCATION"
to
Case "SENDER LOCATION", "LOCATION", "SENDER'S W.U. LOCATION", "SENDER'S W.U. LOCATION(CITY & STATE)"

That change is however made here and also the column resort.

Chris
Sub Q_26900870()
Dim mai As Object
Dim olkApp As Object
Dim folderItems As Variant
Dim sortedItems As Variant
Dim rng As Range
Dim arrRows() As String
Dim arrRow() As String
Dim elem As Variant
Const olFolderinbox As Integer = 6
Const olMail As Integer = 43
    
    Set olkApp = CreateObject("outlook.application")
    Set folderItems = olkApp.Session.Folders("support@sovereigngoldcard.com").Folders("inbox").items
    folderItems.Sort "receivedtime", False
    Set sortedItems = folderItems
    
    ThisWorkbook.Sheets(1).Range("A1:F1") = Array("Receiver", "Date Received", "MCTN", "Sender", "Sender Location", "Amount")
'Receiver - date email received - MTCN - Sender - Sender Location - Amount
    For Each mai In sortedItems
        If mai.Class = olMail Then
            If InStr(1, mai.body, "MTCN", vbTextCompare) > 0 Then
                Set rng = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                arrRows = Split(mai.body, vbCrLf, , vbTextCompare)
                For Each elem In arrRows
                    If Left(elem, 1) = "-" Then
                        Set rng = rng.Offset(1, 0)
                    Else
                        If InStr(elem, ":") > 0 Then
                            arrRow = Split(elem, ":")
                            Select Case Trim(UCase(CStr(arrRow(0))))
                                Case "MTCN", "MTCN#"
                                    rng.Offset(0, 2) = arrRow(1)
                                Case "RECEIVER"
                                    rng = arrRow(1)
                                Case "SENDER"
                                    rng.Offset(0, 3) = arrRow(1)
                                Case "SENDER LOCATION", "LOCATION", "SENDER'S W.U. LOCATION", "SENDER'S W.U. LOCATION(CITY & STATE)"
                                    rng.Offset(0, 4) = arrRow(1)
                                Case "AMOUNT", "AMT"
                                    rng.Offset(0, 5) = arrRow(1)
                                Case Else
                            End Select
                            rng.Offset(0, 1) = mai.receivedtime
                        End If
                    End If
                Next
            End If
        End If
    Next
    rng.Parent.Range("A1:E1").EntireColumn.AutoFit
End Sub

Open in new window

0
 

Author Comment

by:JaseS
ID: 35211106
Thank you for adding the date, don't need the time, although I like it. However, I would just have to go through and delete it, unfortunately. Can you remove it or tell me what to do.

Still missing data for the MTCN number in Tom Armour (Grand Prarie's) entry
and missing all the data for the section immediately below Fernando's entry, not sure why.
Is there anyway to capture the missing data as well, or will I need to go through and manually input those?

We're 99% there. Thank you for your efforts. Let me know if we can tidy it up as mentioned above and we'll call that done.
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
ID: 35211214
Date only as in the change here:

MTCN# 831-802-3xxxx .... No Colon
other missing datums are again because of the lack of colons.  Not a lot I can do in that case.  The original premise was some rows of data can be missing and therefore the colon is critical to extraction of the data as without it we have no idea when the introduction ends, (if it is present at all).

It would seem therefore it is pretty much it as it stands.

Chris
Sub Q_26900870()
Dim mai As Object
Dim olkApp As Object
Dim folderItems As Variant
Dim sortedItems As Variant
Dim rng As Range
Dim arrRows() As String
Dim arrRow() As String
Dim elem As Variant
Const olFolderinbox As Integer = 6
Const olMail As Integer = 43
    
    Set olkApp = CreateObject("outlook.application")
    Set folderItems = olkApp.Session.Folders("support@sovereigngoldcard.com").Folders("inbox").items
    folderItems.Sort "receivedtime", False
    Set sortedItems = folderItems
    
    ThisWorkbook.Sheets(1).Range("A1:F1") = Array("Receiver", "Date Received", "MCTN", "Sender", "Sender Location", "Amount")
'Receiver - date email received - MTCN - Sender - Sender Location - Amount
    For Each mai In sortedItems
        If mai.Class = olMail Then
            If InStr(1, mai.body, "MTCN", vbTextCompare) > 0 Then
                Set rng = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                arrRows = Split(mai.body, vbCrLf, , vbTextCompare)
                For Each elem In arrRows
                    If Left(elem, 1) = "-" Then
                        Set rng = rng.Offset(1, 0)
                    Else
                        If InStr(elem, ":") > 0 Then
                            arrRow = Split(elem, ":")
                            Select Case Trim(UCase(CStr(arrRow(0))))
                                Case "MTCN", "MTCN#"
                                    rng.Offset(0, 2) = arrRow(1)
                                Case "RECEIVER"
                                    rng = arrRow(1)
                                Case "SENDER"
                                    rng.Offset(0, 3) = arrRow(1)
                                Case "SENDER LOCATION", "LOCATION", "SENDER'S W.U. LOCATION", "SENDER'S W.U. LOCATION(CITY & STATE)"
                                    rng.Offset(0, 4) = arrRow(1)
                                Case "AMOUNT", "AMT"
                                    rng.Offset(0, 5) = arrRow(1)
                                Case Else
                            End Select
                            rng.Offset(0, 1) = Format(mai.receivedtime, "dd mmm yyyy")
                        End If
                    End If
                Next
            End If
        End If
    Next
    rng.Parent.Range("A1:E1").EntireColumn.AutoFit
End Sub

Open in new window

0
 

Author Comment

by:JaseS
ID: 35211341
Still putting 0:00 in for time in some emails. Maybe it was the formatting that was there before.
Is it possible to put an empty row between emails?
They are coming in bunched all together. If not, no big deal
I'll try to figure it out.
Let me know about the spacing and I will end the project on your response.

Once again, thank you for your, very much appreciated, hard work.
I do have a couple of other projects involving excel, not Outlook, if you are interested.

0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35211392
Empty row between emails ... possible but I suggest a matter for a new question, (related question post closure perhaps).

Formatting must be carried over ... try settig the sheet format for all cells to general

Chris
0
 

Author Closing Comment

by:JaseS
ID: 35211612
Great job! Very timely and his coding work did exactly what I needed it to do. A++ work!
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

Suggested Solutions

Set OWA language and time zone in Exchange for individuals, all users or per database.
This process describes the steps required to Import and Export data from and to .pst files using Exchange 2010. We can use these steps to export data from a user to a .pst file, import data back to the same or a different user, or even import data t…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

758 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now