Import Email Data to Spreadsheet not Working With All Emails

This question relates to a previous solution given here:
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_27943128.html

However, attached are two emails that do not import to the WU-Staging-FBME worksheet. Others that I regularly get do import.
FW-MG-information-oct-17.msg
RE-WU.MG-information-oct-20.msg
JaseStAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

gowflowCommented:
We are talking about the Visa file right ?
gowflow
0
gowflowCommented:
You used to have MTCN and MG now I see REF# this is for what MG or MTCN ?
gowflow
0
JaseStAuthor Commented:
"We are talking about the Visa file right ?" YES

"You used to have MTCN and MG now I see REF# this is for what MG or MTCN ?"
YES. Didn't catch that it was different than what was used in the past, but they all mean the same thing, either MG or MTCN.
0
The Ultimate Tool Kit for Technolgy Solution Provi

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

gowflowCommented:

YES. Didn't catch that it was different than what was used in the past, but they all mean the same thing, either MG or MTCN.

Well basically it is not importing due to not seeing neither MG nor MTCN.

I need to know what the REF# belongs to as I see the routine has 2 distinctions in the routine either MTCN or MG or it maybe MIX

So is the REF# means it is MG or MTCN ??
gowflow
0
gowflowCommented:
Lookiong again at the routinessss I see maybe I got the wrong question

I see that all MTCN are WU emails ...
and if not MTCN then it is an MG type

so the question  what is a REF# type?
gowflow
0
JaseStAuthor Commented:
Yes, REF# is the same as MG or MTCN. Any number on that first line is the same as MG or MTCN
0
gowflowCommented:
see my second post
gowflow
0
JaseStAuthor Commented:
"so the question  what is a REF# type?"

It is either a MG number or MTCN number. Doesn't matter.
0
gowflowCommented:
ok fine I fixed it. But you cannot import the second email as the subject start with
RE:
RE: WU.MG information oct 20
there is an instruction that says if the subject first 3 letters are RE: then do not process this email.

Any idea why we had this there ???
gowflow
0
JaseStAuthor Commented:
I forwarded the email to myself trying to get it to work. Forgot about removing it. Normally they won't have the "RE:"
0
gowflowCommented:
so it is then normal in the 2 examples that you posted for one 1 to be imported the one with FW: and not the RE: ?

Then I can see that it import the data and continue the numbering in my copy I had last record at item 22 it import this one with a yellow line then 23,24,etc... is this normal or it should start over at 1 ??? forgot about this just to make sure routine is fine before posting.
gowflow
0
JaseStAuthor Commented:
No, it is NOT normal to have either RE: or FW:

Not sure how you had the numbering start again. I think numbering starts at 1 when emails are imported on a different (the next) day.
0
gowflowCommented:

No, it is NOT normal to have either RE: or FW:

You contradict yourself !!!!

The way it is now:
It will import email that does not start with RE:
is this normal behavior ???

For numbering I really don't know. After you reply I will post the code and you try.
gowflow
0
JaseStAuthor Commented:
Yes, do not import emails that start with RE: Re: or FW: or Fw: or any variation thereof.
0
gowflowCommented:
Yes, do not import emails that start with RE: Re: or FW: or Fw: or any variation thereof.

back to square 1 !!!

Post then 2 messages that are not imported and that do not have neither RE: or FW: so I can make sure routine is fine.

gowflow
0
JaseStAuthor Commented:
Ok, WU.MG-information-oct-20-2.msg  imported but did not put in the Ref# to Col D.
Also the "Your Location" info did not get imported but don't worry about that. I just need to tell the sender to not use that terminology.

And MG-information-oct-17-2.msg did not import at all.

WU.MG-information-oct-20-2.msg

MG-information-oct-17-2.msg
0
gowflowCommented:
ok here it is.

You will need to delete the following 2 routines and replace them by the below code in module1
Sub ImportWesternUnion()
Function UpdateItemFound


Sub ImportWesternUnion()
Dim WS As Worksheet
Dim objOutlook As Object
Dim Rng As Range, RngCardHolder As Range
Dim arrRows() As String
Dim arrRow() As String
Dim elem As Variant
Dim FMonitor, FTransfer
Dim FoundDivider As Boolean, FirstItemInMail As Boolean, StartDivider As Boolean
Dim CardNumber As String, CardHolder As String, TmpCardHolder As String
Dim SenderEmail As String
Dim Divider As String
Dim I As Long, J As Long, K As Long, L As Long
Dim C, FirstAddress, Items
Dim TmpAmount As String
Dim Fields As String, Possibility As String
Dim LenItem As Long, ColJRow As Long, ColARow As Long
Dim eType As String

Set objOutlook = CreateObject("Outlook.application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set WS = Sheets("WU-Staging-FBME")


FMonitor = Split(Mid(gstFolderToMonitor, 2), "\")
If Not SetMonitorFolder(FMonitor) Then Exit Sub
wsMain.Range("L" & CRow) = "Import Western Union - FMonitor: " & objFolderToMonitor
CRow = CRow + 1

'Disabled in this procedure as user do not want to move emails.
'FTransfer = Split(Mid(gstFolderToTransfer, 2), "\")
'If Not SetTransferFolder(FTransfer) Then Exit Sub
'wsMain.Range("L" & CRow) = "Locate Emails - FTransfer: " & objFolderToTransfer
'CRow = CRow + 1

Dim VItem As Outlook.MailItem

Set VisaItems = objFolderToMonitor.Items.Restrict("[Subject] <> 'Payment Received'")
VisaItems.Sort "receivedtime", False

'Setting Value of I depending on last item in Col J
ColJRow = WS.Range("J:J").Rows(WS.Range("J:J").Rows.Count).End(xlUp).Row
ColARow = WS.Range("A:A").Rows(WS.Range("A:A").Rows.Count).End(xlUp).Row
WS.Range("D:D").NumberFormat = "@"

If ColARow = ColJRow Then
    I = 1
Else
    I = WS.Cells(ColARow, 1) + 1
End If

Application.EnableEvents = False

For Each VItem In VisaItems
    wsMain.Range("L" & CRow) = "Import WU/MG - Items: " & I & " " & VItem.SenderEmailAddress & " " & VItem
    CRow = CRow + 1

    Set objMail = VItem
    ' use Instr here to check subject or body
    'MsgBox objMail.Subject
    '---> Do not process replied mails.
    If Left(UCase(objMail.Subject), 3) <> "RE:" Then
    
        Body = objMail.Body
        Etime = objMail.ReceivedTime
        CardNumber = ""
        FoundDivider = False
        StartDivider = False
        FirstItemInMail = True
        SenderEmail = objMail.SenderEmailAddress
        
        
        'Split Email address
        Select Case Trim(UCase(SenderEmail))
            Case "WHITE@SECURENYM.NET"
                CardHolder = "Jen" & Format(Etime, "mmddyy")
            Case "LENNOX@SECURENYM.NET"
                CardHolder = "Adam" & Format(Etime, "mmddyy")
            Case "KONG@SECURENYM.NET"
                CardHolder = "Shawn" & Format(Etime, "mmddyy")
            Case "INFO@HOLMSENTREPRISES.COM"
                CardHolder = "Holms" & Format(Etime, "mmddyy")
            Case Else
                CardHolder = SenderEmail & Format(Etime, "mmddyy")
        End Select
        
        'Check to see if Combination CardHolder + Col C date already exist then increment CardHolder by 1
        With WS.Range("M:M")
            TmpCardHolder = CardHolder
            K = 2
            Do
                Set C = .Find(TmpCardHolder, LookIn:=xlValues, lookat:=xlPart)
                If Not C Is Nothing Then
                    TmpCardHolder = CardHolder & "-" & Format(K)
                    K = K + 1
                End If
            Loop Until C Is Nothing
            CardHolder = TmpCardHolder
    
        End With
    
        
        '---> Trap WU or MG Emails
        If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 Or InStr(1, UCase(Body), "MG", vbTextCompare) > 0 Or InStr(1, UCase(Body), "REF#", vbTextCompare) > 0 Then
            
            '---> Set Type of Email for future use
            If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 And (InStr(1, UCase(Body), "MG", vbTextCompare) > 0 Or InStr(1, UCase(Body), "REF#", vbTextCompare) > 0) Then
                eType = "MIX"
            Else
                If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 Then eType = "WU"
                If (InStr(1, UCase(Body), "MG", vbTextCompare) > 0 Or InStr(1, UCase(Body), "REF#", vbTextCompare) > 0) Then eType = "MG"
            End If
            
            If Rng Is Nothing Then
                Set Rng = WS.Range("B" & WS.UsedRange.Rows.Count).Offset(1, 0)
                Rng.Offset(1, 0).EntireRow.Insert
                WS.Range(Rng.Offset(0, -1), Rng.Offset(0, 39)).Interior.ColorIndex = 6
                'Made to trap yellow lines for Export Email
                Rng.Offset(0, 2).Value = " "
            Else
                Rng.Offset(1, 0).EntireRow.Insert
                WS.Range(Rng.Offset(1, -1), Rng.Offset(1, 39)).Interior.ColorIndex = 6
                'Made to trap yellow lines for Export Email
                Rng.Offset(1, 2).Value = " "
                Set Rng = Rng.Offset(1, 0)
            End If
            arrRows = Split(Body, vbCrLf, , vbTextCompare)
            For Each elem In arrRows
        
                'Spot Card Number as 'CARD #'
                If (InStr(1, UCase(elem), "CARD #", vbTextCompare) > 0 Or InStr(1, UCase(elem), "CARD#", vbTextCompare) > 0) And CardNumber = "" Then
                    If InStr(1, UCase(elem), "CARD #", vbTextCompare) > 0 Then CardNumber = Trim(Mid(elem, InStr(1, UCase(elem), "CARD #", vbTextCompare) + 6))
                    If InStr(1, UCase(elem), "CARD#", vbTextCompare) > 0 Then CardNumber = Trim(Mid(elem, InStr(1, UCase(elem), "CARD#", vbTextCompare) + 5))
                    
                    If Not IsNumeric(CardNumber) Then
                        TmpCardNumber = ""
                        For J = 1 To Len(CardNumber)
                            If IsNumeric(Mid(CardNumber, J, 1)) Then TmpCardNumber = TmpCardNumber & Mid(CardNumber, J, 1)
                        Next J
                        CardNumber = TmpCardNumber
                    End If
                    'To prevent other routines to interact
                    elem = ""
                End If
                    
                'Spot when block does not have semicolumn as divider in semicolumn ':' or else use space ' '
                If Left(Trim(elem), 1) <> "-" And Left(Trim(elem), 1) <> "=" And Left(Trim(elem), 1) <> "*" And Trim(elem) <> "" Then
                    If InStr(elem, ":") > 0 Then
                        If InStr(InStr(elem, ":") + 1, elem, ":") > 0 Then
                            Divider = " "
                        Else
                            Divider = ":"
                        End If
                    Else
                        If InStr(elem, ";") > 0 Then
                            If InStr(InStr(elem, ";") + 1, elem, ";") > 0 Then
                                Divider = " "
                            Else
                                Divider = ";"
                            End If
                        Else
                            If InStr(elem, " ") > 0 Then
                                Divider = " "
                            Else
                                Divider = ""
                            End If
                        End If
                    End If
                End If
                    
                'Spot beginning of Items
                If Left(elem, 1) = "-" Or Left(elem, 1) = "=" Then
                    FoundDivider = True
                    StartDivider = True
                End If
                
                
                'Spot Dividers in semicolumn ':' or else use space ' '
                LenItem = 0
                Possibility = ""
                If eType = "MIX" And FoundDivider Then
                    If InStr(1, UCase(elem), "MTCN", vbTextCompare) > 0 Then eType = "WU"
                    If InStr(1, UCase(elem), "MG", vbTextCompare) > 0 Or InStr(1, UCase(elem), "REF#", vbTextCompare) > 0 Then eType = "MG"
                End If
                
                If eType = "WU" Then Fields = "MTCN|MTCN#|MCTN|MCTN#|MTCN #|MTC#|MTCN;"
                If eType = "MG" Then Fields = "MG|MG#|MG #|MG;|REF#"
                
                Items = Split(Fields, "|")
                For L = 0 To UBound(Items)
                    If InStr(1, elem, Items(L), vbTextCompare) > 0 Then
                        If Len(Items(L)) > LenItem Then
                            Possibility = Items(L)
                            LenItem = Len(Items(L))
                        End If
                    End If
                Next L
                If Possibility <> "" Then
                    If Not FoundDivider Then FoundDivider = True
                    If Divider = "" Then
                        Divider = " "
                        elem = Possibility & Divider & Mid(elem, Len(Possibility) + 1)
                    End If
                End If
                    
                If InStr(elem, Divider) > 0 And Divider <> "" Then
                    arrRow = Split(elem, Divider)
                    'Select Case Trim(UCase(CStr(arrRow(0))))
                    '    Case "MTCN", "MTCN#", "MCTN", "MCTN#", "MTCN #", "MTC#", "MTCN;"
                    '        If Not FoundDivider Then FoundDivider = True
                    '
                    'End Select
                
                    
                    If FoundDivider And StartDivider Then
                        'Delete Row if no values
                        If WS.Range(Rng.Offset(0, -1), Rng.Offset(0, 39)).Interior.ColorIndex <> 6 And Rng.Offset(0, 0).Value = "" And Rng.Offset(0, 2).Value = "" And Rng.Offset(0, 3).Value = "" And Rng.Offset(0, 5).Value = "" Then
                            RngDeletd = WS.Cells(Rng.Row - 1, Rng.Column).Address
                            WS.Range(Rng.Row & ":" & Rng.Row).EntireRow.Delete
                            Set Rng = WS.Range(RngDeletd)
                            I = I - 1
                        End If
                        Set Rng = Rng.Offset(1, 0)
                        Rng.Offset(0, 1) = Format(Etime, "dd mmm yyyy")
                        Rng.Offset(0, -1) = I
                        Rng.Offset(0, 11) = CardHolder
                        If FirstItemInMail Then
                            Rng.Offset(0, 16) = CardNumber
                            If Left(CardNumber, 1) = "4" Then Rng.Offset(0, 17) = "EUR"
                            If Left(CardNumber, 1) = "5" Then Rng.Offset(0, 17) = "USD"
                            FirstItemInMail = False
                        End If
                        wsMain.Range("L" & CRow) = "    Item: " & I & " " & VItem.SenderEmailAddress
                        CRow = CRow + 1
                        I = I + 1
                        FoundDivider = False
                    End If
                    
                    
                    If Divider = " " And (CardNumber <> "" Or StartDivider = True) Then
                         X = UpdateItemFound(Rng, elem, eType)
                    Else
                        Select Case Trim(UCase(CStr(arrRow(0))))
                            Case "MTCN", "MTCN#", "MCTN", "MCTN#", "MTCN #", "MTC#", "MTCN;"
                                'Fix to importing MCTN with all characters including leading and trailing zeros
                                If Trim(arrRow(1)) <> "" Then
                                    Rng.Offset(0, 2) = Trim(Format(arrRow(1), "@"))
                                Else
                                    If UBound(arrRow) > 1 Then
                                        Rng.Offset(0, 2) = Trim(Format(arrRow(2), "@"))
                                    End If
                                End If
                            Case "MG", "MG#", "MG #", "MG;", "REF#"
                                'Fix to importing MG with all characters including leading and trailing zeros
                                If Trim(arrRow(1)) <> "" Then
                                    Rng.Offset(0, 2) = Trim(Format(arrRow(1), "@"))
                                Else
                                    If UBound(arrRow) > 1 Then
                                        Rng.Offset(0, 2) = Trim(Format(arrRow(2), "@"))
                                    End If
                                End If
                            Case "RECEIVER", "RECIEVER INFO", "RECEIVER NAME", "RECIEVER", "RECEVIER", "RECIVER", "RCVR"
                                Rng = Trim(arrRow(1))
                            Case "SENDER LOCATION", "LOCATION", "SENDER'S W.U. LOCATION", "SENDER'S W.U. LOCATION(CITY & STATE)", "SENDERS W.U. LOCATION", "SENDER'S W.U. LOCATION (CITY AND STATE)", "SENDER'S LOCATION", "SENDER INFO", "SENDER LOC ", "W U LOCATION", "SENDER WU LOCATION", "SEND LOC ", "SENDER LOC", "SENDER LOC", "SENDERS WU LOCATIONS", "SENDERS W.U'S LOCATION", "SENDERS W/U LOCATION", "ADDRESS", "SENDERS W.U. LOCATION", "SENDERS LOCATION", "SENDER WU LOCATION", "SENDER LOCATION SENT", "SENDER W/U LOCATION", "SENDER W.U. LOCATION", "W.U. LOCATION", "W/U LOCATION", "W.U. LOCTION", "SENDER LOC.", "AMT SENT", "SENT FROM", "WU LOCATION", "LOCATION.", "LOC.", "SENDING WU LOCATION", "CITY", "YOUR LOCATION"
                                Rng.Offset(0, 4) = Trim(arrRow(1))
                            Case "AMOUNT", "AMT", "AMOUNT SENT", "TOTAL", "TOTAL AMOUNT", "AOUNT", "MOUNT", "AMMOUNT", "AMNT", "AMOUNT $"
                                'Fix to importing amount as a number formated as $currency with double digits and
                                'Red if negatives
                                If Not IsNumeric(arrRow(1)) Then
                                    TmpAmount = ""
                                    For J = 1 To Len(elem)
                                        If IsNumeric(Mid(elem, J, 1)) Or Mid(elem, J, 1) = "." Then TmpAmount = TmpAmount & Mid(elem, J, 1)
                                    Next J
                                    arrRow(1) = TmpAmount
                                End If
                                If arrRow(1) <> "" Then Rng.Offset(0, 5) = CDbl(arrRow(1))
                                Rng.Offset(0, 5).NumberFormat = "$#,##0.00;[Red]($#,##0.00)"
                            Case "SENDER", "ENDER"
                                Rng.Offset(0, 3) = Trim(arrRow(1))
                            Case Else
                        End Select
                        
                    End If
                End If
                
            Next elem
        End If
    Else
        wsMain.Range("L" & CRow) = "Import WU/MG - Items: " & I & " Not Processed as History Mail."
        CRow = CRow + 1
    End If
Next VItem

Application.EnableEvents = True

'WS.UsedRange.EntireColumn.AutoFit
X = MsgBox("Total of " & I & " WU/MG detailed transfer imported successfully." & Chr(10) _
    & "Please check data in sheet 'WU-Staging-FBME' and make necessary corrections if any before proceeding to Step 2 - [Generate WU File]", vbInformation, "Step 1 - Import WU Emails")

End Sub




Function UpdateItemFound(Rng As Range, elem As Variant, Typ As String) As Long
Dim I As Long, J As Long, K As Long, L As Long, LenItem As Long
Dim Fields(5) As String
Dim Items, Item, TmpAmount
Dim ItemFound(5, 2) As Integer
Dim Possibility As String
Dim IFound As Boolean

If Typ = "WU" Then
    Fields(1) = "MTCN|MTCN#|MCTN|MCTN#|MTCN #|MTC#|MTCN;"
Else
    Fields(1) = "MG|MG#|MG #|MG;|REF#"
End If
Fields(2) = "RECEIVER|RECIEVER INFO|RECEIVER NAME|RECIEVER|RECEVIER|RECIVER|RCVR"
Fields(3) = "SENDER LOCATION|LOCATION|SENDER'S W.U. LOCATION|SENDER'S W.U. LOCATION(CITY & STATE)|SENDERS W.U. LOCATION|SENDER'S W.U. LOCATION (CITY AND STATE)|SENDER'S LOCATION|SENDER INFO|SENDER LOC |W U LOCATION|SENDER WU LOCATION|SEND LOC |SENDER LOC|SENDER LOC|SENDERS WU LOCATIONS|SENDERS W.U'S LOCATION|SENDERS W/U LOCATION|ADDRESS|SENDERS W.U. LOCATION|SENDERS LOCATION|SENDER WU LOCATION|SENDER LOCATION SENT|SENDER W/U LOCATION|SENDER W.U. LOCATION|W.U. LOCATION|W/U LOCATION|W.U. LOCTION|SENDER LOC.|AMT SENT|SENT FROM|WU LOCATION|LOCATION.|LOC.|SENDING WU LOCATION|CITY|YOUR LOCATION"
Fields(4) = "AMOUNT|AMT|AMOUNT SENT|TOTAL|TOTAL AMOUNT|AOUNT|MOUNT|AMMOUNT|AMNT|AMOUNT $"
Fields(5) = "SENDER|ENDER"

For I = 1 To 5
    Items = Split(Fields(I), "|")
    Possibility = ""
    LenItem = 0
    For J = 0 To UBound(Items)
        If InStr(1, elem, Items(J), vbTextCompare) > 0 And ItemFound(I, 0) = 0 Then
            'Find all possibilities for the item
            If Len(Items(J)) > LenItem Then
                'If Possibility <> "" Then Possibility = Possibility & "|"
                Possibility = Items(J)
                LenItem = Len(Items(J))
            End If
        End If
    Next J
            
   If Possibility <> "" Then
            
            Select Case I
                Case 1  'MTCN
                    If Rng.Offset(0, 2) = "" Then
                        If InStr(1, elem, ":", vbTextCompare) > 0 Then
                            Item = Trim(Mid(elem, InStr(1, elem, ":", vbTextCompare) + 1))
                        Else
                            Item = Trim(Mid(elem, Len(Possibility) + 1))
                        End If
                        Rng.Offset(0, 2) = Trim(Format(Item, "@"))
                        For L = 1 To 5
                            If ItemFound(L, 0) <> 0 And I <> L Then
                                Rng.Offset(0, ItemFound(L, 1)) = Trim(Mid(Rng.Offset(0, ItemFound(L, 1)), 1, InStr(1, Rng.Offset(0, ItemFound(L, 1)), Possibility, vbTextCompare) - 1))
                                Exit For
                            End If
                        Next L
                        
                        ItemFound(I, 0) = I
                        ItemFound(I, 1) = 2
                        IFound = True
                    End If
                    
                Case 2  'Reciever
                    If Rng.Offset(0, 0) = "" Then
                        If InStr(1, elem, ":", vbTextCompare) > 0 Then
                            Item = Trim(Mid(elem, InStr(1, elem, ":", vbTextCompare) + 1))
                        Else
                            Item = Trim(Mid(elem, Len(Possibility) + 1))
                        End If
                        Rng = Trim(Item)
                        For L = 1 To 5
                            If ItemFound(L, 0) <> 0 And I <> L Then
                                Rng.Offset(0, ItemFound(L, 1)) = Trim(Mid(Rng.Offset(0, ItemFound(L, 1)), 1, InStr(1, Rng.Offset(0, ItemFound(L, 1)), Possibility, vbTextCompare) - 1))
                                Exit For
                            End If
                        Next L
                        
                        ItemFound(I, 0) = I
                        ItemFound(I, 1) = 0
                        IFound = True
                    End If
                    
                Case 3  'Location
                    If Rng.Offset(0, 4) = "" Then
                        If InStr(1, elem, ":", vbTextCompare) > 0 Then
                            Item = Trim(Mid(elem, InStr(1, elem, ":", vbTextCompare) + 1))
                        Else
                            Item = Trim(Mid(elem, Len(Possibility) + 1))
                        End If
                        Rng.Offset(0, 4) = Trim(Item)
                        For L = 1 To 5
                            If ItemFound(L, 0) <> 0 And I <> L Then
                                Rng.Offset(0, ItemFound(L, 1)) = Trim(Mid(Rng.Offset(0, ItemFound(L, 1)), 1, InStr(1, Rng.Offset(0, ItemFound(L, 1)), Possibility, vbTextCompare) - 1))
                                Exit For
                            End If
                        Next L
                        
                        ItemFound(I, 0) = I
                        ItemFound(I, 1) = 4
                        IFound = True
                    End If
                                                        
                Case 4  'Amount
                    If Rng.Offset(0, 5) = "" Then
                        If InStr(1, elem, ":", vbTextCompare) > 0 Then
                            Item = Trim(Mid(elem, InStr(1, elem, ":", vbTextCompare) + 1))
                        Else
                            Item = Trim(Mid(elem, Len(Possibility) + 1))
                        End If
                        If Not IsNumeric(Item) Then
                            TmpAmount = ""
                            For K = 1 To Len(Item)
                                If IsNumeric(Mid(Item, K, 1)) Or Mid(Item, K, 1) = "." Then TmpAmount = TmpAmount & Mid(Item, K, 1)
                            Next K
                            Item = TmpAmount
                        End If
                        Rng.Offset(0, 5) = CDbl(Item)
                        Rng.Offset(0, 5).NumberFormat = "$#,##0.00;[Red]($#,##0.00)"
                        For L = 1 To 5
                            If ItemFound(L, 0) <> 0 And I <> L Then
                                Rng.Offset(0, ItemFound(L, 1)) = Trim(Mid(Rng.Offset(0, ItemFound(L, 1)), 1, InStr(1, Rng.Offset(0, ItemFound(L, 1)), Possibility, vbTextCompare) - 1))
                                Exit For
                            End If
                        Next L
                        
                        ItemFound(I, 0) = I
                        ItemFound(I, 1) = 5
                        IFound = True
                    End If
                    
                Case 5  'Sender
                    If Rng.Offset(0, 3) = "" Then
                        If InStr(1, elem, ":", vbTextCompare) > 0 Then
                            Item = Trim(Mid(elem, InStr(1, elem, ":", vbTextCompare) + 1))
                        Else
                            Item = Trim(Mid(elem, Len(Possibility) + 1))
                        End If
                        Rng.Offset(0, 3) = Trim(Item)
                        For L = 1 To 5
                            If ItemFound(L, 0) <> 0 And I <> L Then
                                Rng.Offset(0, ItemFound(L, 1)) = Trim(Mid(Rng.Offset(0, ItemFound(L, 1)), 1, InStr(1, Rng.Offset(0, ItemFound(L, 1)), Possibility, vbTextCompare) - 1))
                                Exit For
                            End If
                        Next L
                        
                        ItemFound(I, 0) = I
                        ItemFound(I, 1) = 3
                        IFound = True
                    End If
                    
            End Select
  End If
Next I
If IFound = True Then
    UpdateItemFound = True
Else
    UpdateItemFound = False
End If
End Function

Open in new window




No worry it will work also  on the Your Location no need to advise client not to put it.
gowflow
0
JaseStAuthor Commented:
Thank you.

Can I add Fisherman@ as I did below? And if so, is that all I have to do when adding another email to the list?

Select Case Trim(UCase(SenderEmail))
            Case "WHITE@SECURENYM.NET"
                CardHolder = "Jen" & Format(Etime, "mmddyy")
            Case "LENNOX@SECURENYM.NET"
                CardHolder = "Adam" & Format(Etime, "mmddyy")
            Case "FISHERMAN@ALPINAASIA.COM"
                CardHolder = "Adam" & Format(Etime, "mmddyy")
            Case "KONG@SECURENYM.NET"
                CardHolder = "Shawn" & Format(Etime, "mmddyy")
            Case "INFO@HOLMSENTREPRISES.COM"
                CardHolder = "Holms" & Format(Etime, "mmddyy")
            Case Else
                CardHolder = SenderEmail & Format(Etime, "mmddyy")
        End Select
0
gowflowCommented:
yes true
Shall I update my copy with this block ?
gowflow
0
JaseStAuthor Commented:
sure, that would be great. Thank you.
0
gowflowCommented:
ok done. Did you try it did it work for you ?
gowflow
0
JaseStAuthor Commented:
Done? Where?
0
gowflowCommented:
if you did it on your copy I did it on mine. no need to send you the whole routine for that line added you did fine.
gowflow
0
JaseStAuthor Commented:
No didn't work entirely.

Did not import the REF # value for  WU.MG-information-oct-20-2.msg and the WU.MG-information-oct-17-2.msg did not import at all.
0
gowflowCommented:
what button are you pressing ?
Import WU / MG Emails ?
yellow button ?
gowflow
0
JaseStAuthor Commented:
Yes, and while it is importing another WU email in my Inbox it is overlooking the WU.MG-information-oct-17-2.msg.

I upload it again for you to look at if that is helpful.

MG-information-oct-17-2.msg
0
gowflowCommented:
I had tested it and tested it again with the file you attached and it imports it butifully. I fear that you did not update the macro properly.

Maybe I should give you the whole thing step by step

1) Make a copy of your last Visa file (prior to last update you did) and give it a new name.
2) Open VBA goto module1 and press on the bottom left icon to view 1 sub at a time
3) Select Sub ImportWesternUnion() and delete all the code that is there.
4) Select Function UpdateItemFound and delete all the code that is there
5) Paste the below code after any End Sub

Sub ImportWesternUnion()
Dim WS As Worksheet
Dim objOutlook As Object
Dim Rng As Range, RngCardHolder As Range
Dim arrRows() As String
Dim arrRow() As String
Dim elem As Variant
Dim FMonitor, FTransfer
Dim FoundDivider As Boolean, FirstItemInMail As Boolean, StartDivider As Boolean
Dim CardNumber As String, CardHolder As String, TmpCardHolder As String
Dim SenderEmail As String
Dim Divider As String
Dim I As Long, J As Long, K As Long, L As Long
Dim C, FirstAddress, Items
Dim TmpAmount As String
Dim Fields As String, Possibility As String
Dim LenItem As Long, ColJRow As Long, ColARow As Long
Dim eType As String

Set objOutlook = CreateObject("Outlook.application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set WS = Sheets("WU-Staging-FBME")


FMonitor = Split(Mid(gstFolderToMonitor, 2), "\")
If Not SetMonitorFolder(FMonitor) Then Exit Sub
wsMain.Range("L" & CRow) = "Import Western Union - FMonitor: " & objFolderToMonitor
CRow = CRow + 1

'Disabled in this procedure as user do not want to move emails.
'FTransfer = Split(Mid(gstFolderToTransfer, 2), "\")
'If Not SetTransferFolder(FTransfer) Then Exit Sub
'wsMain.Range("L" & CRow) = "Locate Emails - FTransfer: " & objFolderToTransfer
'CRow = CRow + 1

Dim VItem As Outlook.MailItem

Set VisaItems = objFolderToMonitor.Items.Restrict("[Subject] <> 'Payment Received'")
VisaItems.Sort "receivedtime", False

'Setting Value of I depending on last item in Col J
ColJRow = WS.Range("J:J").Rows(WS.Range("J:J").Rows.Count).End(xlUp).Row
ColARow = WS.Range("A:A").Rows(WS.Range("A:A").Rows.Count).End(xlUp).Row
WS.Range("D:D").NumberFormat = "@"

If ColARow = ColJRow Then
    I = 1
Else
    I = WS.Cells(ColARow, 1) + 1
End If

Application.EnableEvents = False

For Each VItem In VisaItems
    wsMain.Range("L" & CRow) = "Import WU/MG - Items: " & I & " " & VItem.SenderEmailAddress & " " & VItem
    CRow = CRow + 1

    Set objMail = VItem
    ' use Instr here to check subject or body
    'MsgBox objMail.Subject
    '---> Do not process replied mails.
    If Left(UCase(objMail.Subject), 3) <> "RE:" Then
    
        Body = objMail.Body
        Etime = objMail.ReceivedTime
        CardNumber = ""
        FoundDivider = False
        StartDivider = False
        FirstItemInMail = True
        SenderEmail = objMail.SenderEmailAddress
        
        
        'Split Email address
        Select Case Trim(UCase(SenderEmail))
            Case "WHITE@SECURENYM.NET"
                CardHolder = "Jen" & Format(Etime, "mmddyy")
            Case "LENNOX@SECURENYM.NET"
                CardHolder = "Adam" & Format(Etime, "mmddyy")
            Case "FISHERMAN@ALPINAASIA.COM"
                CardHolder = "Adam" & Format(Etime, "mmddyy")
            Case "KONG@SECURENYM.NET"
                CardHolder = "Shawn" & Format(Etime, "mmddyy")
            Case "INFO@HOLMSENTREPRISES.COM"
                CardHolder = "Holms" & Format(Etime, "mmddyy")
            Case Else
                CardHolder = SenderEmail & Format(Etime, "mmddyy")
        End Select
        
        'Check to see if Combination CardHolder + Col C date already exist then increment CardHolder by 1
        With WS.Range("M:M")
            TmpCardHolder = CardHolder
            K = 2
            Do
                Set C = .Find(TmpCardHolder, LookIn:=xlValues, lookat:=xlPart)
                If Not C Is Nothing Then
                    TmpCardHolder = CardHolder & "-" & Format(K)
                    K = K + 1
                End If
            Loop Until C Is Nothing
            CardHolder = TmpCardHolder
    
        End With
    
        
        '---> Trap WU or MG Emails
        If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 Or InStr(1, UCase(Body), "MG", vbTextCompare) > 0 Or InStr(1, UCase(Body), "REF#", vbTextCompare) > 0 Then
            
            '---> Set Type of Email for future use
            If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 And (InStr(1, UCase(Body), "MG", vbTextCompare) > 0 Or InStr(1, UCase(Body), "REF#", vbTextCompare) > 0) Then
                eType = "MIX"
            Else
                If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 Then eType = "WU"
                If (InStr(1, UCase(Body), "MG", vbTextCompare) > 0 Or InStr(1, UCase(Body), "REF#", vbTextCompare) > 0) Then eType = "MG"
            End If
            
            If Rng Is Nothing Then
                Set Rng = WS.Range("B" & WS.UsedRange.Rows.Count).Offset(1, 0)
                Rng.Offset(1, 0).EntireRow.Insert
                WS.Range(Rng.Offset(0, -1), Rng.Offset(0, 39)).Interior.ColorIndex = 6
                'Made to trap yellow lines for Export Email
                Rng.Offset(0, 2).Value = " "
            Else
                Rng.Offset(1, 0).EntireRow.Insert
                WS.Range(Rng.Offset(1, -1), Rng.Offset(1, 39)).Interior.ColorIndex = 6
                'Made to trap yellow lines for Export Email
                Rng.Offset(1, 2).Value = " "
                Set Rng = Rng.Offset(1, 0)
            End If
            arrRows = Split(Body, vbCrLf, , vbTextCompare)
            For Each elem In arrRows
        
                'Spot Card Number as 'CARD #'
                If (InStr(1, UCase(elem), "CARD #", vbTextCompare) > 0 Or InStr(1, UCase(elem), "CARD#", vbTextCompare) > 0) And CardNumber = "" Then
                    If InStr(1, UCase(elem), "CARD #", vbTextCompare) > 0 Then CardNumber = Trim(Mid(elem, InStr(1, UCase(elem), "CARD #", vbTextCompare) + 6))
                    If InStr(1, UCase(elem), "CARD#", vbTextCompare) > 0 Then CardNumber = Trim(Mid(elem, InStr(1, UCase(elem), "CARD#", vbTextCompare) + 5))
                    
                    If Not IsNumeric(CardNumber) Then
                        TmpCardNumber = ""
                        For J = 1 To Len(CardNumber)
                            If IsNumeric(Mid(CardNumber, J, 1)) Then TmpCardNumber = TmpCardNumber & Mid(CardNumber, J, 1)
                        Next J
                        CardNumber = TmpCardNumber
                    End If
                    'To prevent other routines to interact
                    elem = ""
                End If
                    
                'Spot when block does not have semicolumn as divider in semicolumn ':' or else use space ' '
                If Left(Trim(elem), 1) <> "-" And Left(Trim(elem), 1) <> "=" And Left(Trim(elem), 1) <> "*" And Trim(elem) <> "" Then
                    If InStr(elem, ":") > 0 Then
                        If InStr(InStr(elem, ":") + 1, elem, ":") > 0 Then
                            Divider = " "
                        Else
                            Divider = ":"
                        End If
                    Else
                        If InStr(elem, ";") > 0 Then
                            If InStr(InStr(elem, ";") + 1, elem, ";") > 0 Then
                                Divider = " "
                            Else
                                Divider = ";"
                            End If
                        Else
                            If InStr(elem, " ") > 0 Then
                                Divider = " "
                            Else
                                Divider = ""
                            End If
                        End If
                    End If
                End If
                    
                'Spot beginning of Items
                If Left(elem, 1) = "-" Or Left(elem, 1) = "=" Then
                    FoundDivider = True
                    StartDivider = True
                End If
                
                
                'Spot Dividers in semicolumn ':' or else use space ' '
                LenItem = 0
                Possibility = ""
                If eType = "MIX" And FoundDivider Then
                    If InStr(1, UCase(elem), "MTCN", vbTextCompare) > 0 Then eType = "WU"
                    If InStr(1, UCase(elem), "MG", vbTextCompare) > 0 Or InStr(1, UCase(elem), "REF#", vbTextCompare) > 0 Then eType = "MG"
                End If
                
                If eType = "WU" Then Fields = "MTCN|MTCN#|MCTN|MCTN#|MTCN #|MTC#|MTCN;"
                If eType = "MG" Then Fields = "MG|MG#|MG #|MG;|REF#"
                
                Items = Split(Fields, "|")
                For L = 0 To UBound(Items)
                    If InStr(1, elem, Items(L), vbTextCompare) > 0 Then
                        If Len(Items(L)) > LenItem Then
                            Possibility = Items(L)
                            LenItem = Len(Items(L))
                        End If
                    End If
                Next L
                If Possibility <> "" Then
                    If Not FoundDivider Then FoundDivider = True
                    If Divider = "" Then
                        Divider = " "
                        elem = Possibility & Divider & Mid(elem, Len(Possibility) + 1)
                    End If
                End If
                    
                If InStr(elem, Divider) > 0 And Divider <> "" Then
                    arrRow = Split(elem, Divider)
                    'Select Case Trim(UCase(CStr(arrRow(0))))
                    '    Case "MTCN", "MTCN#", "MCTN", "MCTN#", "MTCN #", "MTC#", "MTCN;"
                    '        If Not FoundDivider Then FoundDivider = True
                    '
                    'End Select
                
                    
                    If FoundDivider And StartDivider Then
                        'Delete Row if no values
                        If WS.Range(Rng.Offset(0, -1), Rng.Offset(0, 39)).Interior.ColorIndex <> 6 And Rng.Offset(0, 0).Value = "" And Rng.Offset(0, 2).Value = "" And Rng.Offset(0, 3).Value = "" And Rng.Offset(0, 5).Value = "" Then
                            RngDeletd = WS.Cells(Rng.Row - 1, Rng.Column).Address
                            WS.Range(Rng.Row & ":" & Rng.Row).EntireRow.Delete
                            Set Rng = WS.Range(RngDeletd)
                            I = I - 1
                        End If
                        Set Rng = Rng.Offset(1, 0)
                        Rng.Offset(0, 1) = Format(Etime, "dd mmm yyyy")
                        Rng.Offset(0, -1) = I
                        Rng.Offset(0, 11) = CardHolder
                        If FirstItemInMail Then
                            Rng.Offset(0, 16) = CardNumber
                            If Left(CardNumber, 1) = "4" Then Rng.Offset(0, 17) = "EUR"
                            If Left(CardNumber, 1) = "5" Then Rng.Offset(0, 17) = "USD"
                            FirstItemInMail = False
                        End If
                        wsMain.Range("L" & CRow) = "    Item: " & I & " " & VItem.SenderEmailAddress
                        CRow = CRow + 1
                        I = I + 1
                        FoundDivider = False
                    End If
                    
                    
                    If Divider = " " And (CardNumber <> "" Or StartDivider = True) Then
                         X = UpdateItemFound(Rng, elem, eType)
                    Else
                        Select Case Trim(UCase(CStr(arrRow(0))))
                            Case "MTCN", "MTCN#", "MCTN", "MCTN#", "MTCN #", "MTC#", "MTCN;"
                                'Fix to importing MCTN with all characters including leading and trailing zeros
                                If Trim(arrRow(1)) <> "" Then
                                    Rng.Offset(0, 2) = Trim(Format(arrRow(1), "@"))
                                Else
                                    If UBound(arrRow) > 1 Then
                                        Rng.Offset(0, 2) = Trim(Format(arrRow(2), "@"))
                                    End If
                                End If
                            Case "MG", "MG#", "MG #", "MG;", "REF#"
                                'Fix to importing MG with all characters including leading and trailing zeros
                                If Trim(arrRow(1)) <> "" Then
                                    Rng.Offset(0, 2) = Trim(Format(arrRow(1), "@"))
                                Else
                                    If UBound(arrRow) > 1 Then
                                        Rng.Offset(0, 2) = Trim(Format(arrRow(2), "@"))
                                    End If
                                End If
                            Case "RECEIVER", "RECIEVER INFO", "RECEIVER NAME", "RECIEVER", "RECEVIER", "RECIVER", "RCVR"
                                Rng = Trim(arrRow(1))
                            Case "SENDER LOCATION", "LOCATION", "SENDER'S W.U. LOCATION", "SENDER'S W.U. LOCATION(CITY & STATE)", "SENDERS W.U. LOCATION", "SENDER'S W.U. LOCATION (CITY AND STATE)", "SENDER'S LOCATION", "SENDER INFO", "SENDER LOC ", "W U LOCATION", "SENDER WU LOCATION", "SEND LOC ", "SENDER LOC", "SENDER LOC", "SENDERS WU LOCATIONS", "SENDERS W.U'S LOCATION", "SENDERS W/U LOCATION", "ADDRESS", "SENDERS W.U. LOCATION", "SENDERS LOCATION", "SENDER WU LOCATION", "SENDER LOCATION SENT", "SENDER W/U LOCATION", "SENDER W.U. LOCATION", "W.U. LOCATION", "W/U LOCATION", "W.U. LOCTION", "SENDER LOC.", "AMT SENT", "SENT FROM", "WU LOCATION", "LOCATION.", "LOC.", "SENDING WU LOCATION", "CITY", "YOUR LOCATION"
                                Rng.Offset(0, 4) = Trim(arrRow(1))
                            Case "AMOUNT", "AMT", "AMOUNT SENT", "TOTAL", "TOTAL AMOUNT", "AOUNT", "MOUNT", "AMMOUNT", "AMNT", "AMOUNT $"
                                'Fix to importing amount as a number formated as $currency with double digits and
                                'Red if negatives
                                If Not IsNumeric(arrRow(1)) Then
                                    TmpAmount = ""
                                    For J = 1 To Len(elem)
                                        If IsNumeric(Mid(elem, J, 1)) Or Mid(elem, J, 1) = "." Then TmpAmount = TmpAmount & Mid(elem, J, 1)
                                    Next J
                                    arrRow(1) = TmpAmount
                                End If
                                If arrRow(1) <> "" Then Rng.Offset(0, 5) = CDbl(arrRow(1))
                                Rng.Offset(0, 5).NumberFormat = "$#,##0.00;[Red]($#,##0.00)"
                            Case "SENDER", "ENDER"
                                Rng.Offset(0, 3) = Trim(arrRow(1))
                            Case Else
                        End Select
                        
                    End If
                End If
                
            Next elem
        End If
    Else
        wsMain.Range("L" & CRow) = "Import WU/MG - Items: " & I & " Not Processed as History Mail."
        CRow = CRow + 1
    End If
Next VItem

Application.EnableEvents = True

'WS.UsedRange.EntireColumn.AutoFit
X = MsgBox("Total of " & I & " WU/MG detailed transfer imported successfully." & Chr(10) _
    & "Please check data in sheet 'WU-Staging-FBME' and make necessary corrections if any before proceeding to Step 2 - [Generate WU File]", vbInformation, "Step 1 - Import WU Emails")

End Sub


Function UpdateItemFound(Rng As Range, elem As Variant, Typ As String) As Long
Dim I As Long, J As Long, K As Long, L As Long, LenItem As Long
Dim Fields(5) As String
Dim Items, Item, TmpAmount
Dim ItemFound(5, 2) As Integer
Dim Possibility As String
Dim IFound As Boolean

If Typ = "WU" Then
    Fields(1) = "MTCN|MTCN#|MCTN|MCTN#|MTCN #|MTC#|MTCN;"
Else
    Fields(1) = "MG|MG#|MG #|MG;|REF#"
End If
Fields(2) = "RECEIVER|RECIEVER INFO|RECEIVER NAME|RECIEVER|RECEVIER|RECIVER|RCVR"
Fields(3) = "SENDER LOCATION|LOCATION|SENDER'S W.U. LOCATION|SENDER'S W.U. LOCATION(CITY & STATE)|SENDERS W.U. LOCATION|SENDER'S W.U. LOCATION (CITY AND STATE)|SENDER'S LOCATION|SENDER INFO|SENDER LOC |W U LOCATION|SENDER WU LOCATION|SEND LOC |SENDER LOC|SENDER LOC|SENDERS WU LOCATIONS|SENDERS W.U'S LOCATION|SENDERS W/U LOCATION|ADDRESS|SENDERS W.U. LOCATION|SENDERS LOCATION|SENDER WU LOCATION|SENDER LOCATION SENT|SENDER W/U LOCATION|SENDER W.U. LOCATION|W.U. LOCATION|W/U LOCATION|W.U. LOCTION|SENDER LOC.|AMT SENT|SENT FROM|WU LOCATION|LOCATION.|LOC.|SENDING WU LOCATION|CITY|YOUR LOCATION"
Fields(4) = "AMOUNT|AMT|AMOUNT SENT|TOTAL|TOTAL AMOUNT|AOUNT|MOUNT|AMMOUNT|AMNT|AMOUNT $"
Fields(5) = "SENDER|ENDER"

For I = 1 To 5
    Items = Split(Fields(I), "|")
    Possibility = ""
    LenItem = 0
    For J = 0 To UBound(Items)
        If InStr(1, elem, Items(J), vbTextCompare) > 0 And ItemFound(I, 0) = 0 Then
            'Find all possibilities for the item
            If Len(Items(J)) > LenItem Then
                'If Possibility <> "" Then Possibility = Possibility & "|"
                Possibility = Items(J)
                LenItem = Len(Items(J))
            End If
        End If
    Next J
            
   If Possibility <> "" Then
            
            Select Case I
                Case 1  'MTCN
                    If Rng.Offset(0, 2) = "" Then
                        If InStr(1, elem, ":", vbTextCompare) > 0 Then
                            Item = Trim(Mid(elem, InStr(1, elem, ":", vbTextCompare) + 1))
                        Else
                            Item = Trim(Mid(elem, Len(Possibility) + 1))
                        End If
                        Rng.Offset(0, 2) = Trim(Format(Item, "@"))
                        For L = 1 To 5
                            If ItemFound(L, 0) <> 0 And I <> L Then
                                Rng.Offset(0, ItemFound(L, 1)) = Trim(Mid(Rng.Offset(0, ItemFound(L, 1)), 1, InStr(1, Rng.Offset(0, ItemFound(L, 1)), Possibility, vbTextCompare) - 1))
                                Exit For
                            End If
                        Next L
                        
                        ItemFound(I, 0) = I
                        ItemFound(I, 1) = 2
                        IFound = True
                    End If
                    
                Case 2  'Reciever
                    If Rng.Offset(0, 0) = "" Then
                        If InStr(1, elem, ":", vbTextCompare) > 0 Then
                            Item = Trim(Mid(elem, InStr(1, elem, ":", vbTextCompare) + 1))
                        Else
                            Item = Trim(Mid(elem, Len(Possibility) + 1))
                        End If
                        Rng = Trim(Item)
                        For L = 1 To 5
                            If ItemFound(L, 0) <> 0 And I <> L Then
                                Rng.Offset(0, ItemFound(L, 1)) = Trim(Mid(Rng.Offset(0, ItemFound(L, 1)), 1, InStr(1, Rng.Offset(0, ItemFound(L, 1)), Possibility, vbTextCompare) - 1))
                                Exit For
                            End If
                        Next L
                        
                        ItemFound(I, 0) = I
                        ItemFound(I, 1) = 0
                        IFound = True
                    End If
                    
                Case 3  'Location
                    If Rng.Offset(0, 4) = "" Then
                        If InStr(1, elem, ":", vbTextCompare) > 0 Then
                            Item = Trim(Mid(elem, InStr(1, elem, ":", vbTextCompare) + 1))
                        Else
                            Item = Trim(Mid(elem, Len(Possibility) + 1))
                        End If
                        Rng.Offset(0, 4) = Trim(Item)
                        For L = 1 To 5
                            If ItemFound(L, 0) <> 0 And I <> L Then
                                Rng.Offset(0, ItemFound(L, 1)) = Trim(Mid(Rng.Offset(0, ItemFound(L, 1)), 1, InStr(1, Rng.Offset(0, ItemFound(L, 1)), Possibility, vbTextCompare) - 1))
                                Exit For
                            End If
                        Next L
                        
                        ItemFound(I, 0) = I
                        ItemFound(I, 1) = 4
                        IFound = True
                    End If
                                                        
                Case 4  'Amount
                    If Rng.Offset(0, 5) = "" Then
                        If InStr(1, elem, ":", vbTextCompare) > 0 Then
                            Item = Trim(Mid(elem, InStr(1, elem, ":", vbTextCompare) + 1))
                        Else
                            Item = Trim(Mid(elem, Len(Possibility) + 1))
                        End If
                        If Not IsNumeric(Item) Then
                            TmpAmount = ""
                            For K = 1 To Len(Item)
                                If IsNumeric(Mid(Item, K, 1)) Or Mid(Item, K, 1) = "." Then TmpAmount = TmpAmount & Mid(Item, K, 1)
                            Next K
                            Item = TmpAmount
                        End If
                        Rng.Offset(0, 5) = CDbl(Item)
                        Rng.Offset(0, 5).NumberFormat = "$#,##0.00;[Red]($#,##0.00)"
                        For L = 1 To 5
                            If ItemFound(L, 0) <> 0 And I <> L Then
                                Rng.Offset(0, ItemFound(L, 1)) = Trim(Mid(Rng.Offset(0, ItemFound(L, 1)), 1, InStr(1, Rng.Offset(0, ItemFound(L, 1)), Possibility, vbTextCompare) - 1))
                                Exit For
                            End If
                        Next L
                        
                        ItemFound(I, 0) = I
                        ItemFound(I, 1) = 5
                        IFound = True
                    End If
                    
                Case 5  'Sender
                    If Rng.Offset(0, 3) = "" Then
                        If InStr(1, elem, ":", vbTextCompare) > 0 Then
                            Item = Trim(Mid(elem, InStr(1, elem, ":", vbTextCompare) + 1))
                        Else
                            Item = Trim(Mid(elem, Len(Possibility) + 1))
                        End If
                        Rng.Offset(0, 3) = Trim(Item)
                        For L = 1 To 5
                            If ItemFound(L, 0) <> 0 And I <> L Then
                                Rng.Offset(0, ItemFound(L, 1)) = Trim(Mid(Rng.Offset(0, ItemFound(L, 1)), 1, InStr(1, Rng.Offset(0, ItemFound(L, 1)), Possibility, vbTextCompare) - 1))
                                Exit For
                            End If
                        Next L
                        
                        ItemFound(I, 0) = I
                        ItemFound(I, 1) = 3
                        IFound = True
                    End If
                    
            End Select
  End If
Next I
If IFound = True Then
    UpdateItemFound = True
Else
    UpdateItemFound = False
End If
End Function

Open in new window


6) SAVE and Exit the workbook
7) open it and give it a try

gowflow
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
JaseStAuthor Commented:
worked beautifully as you said, gowflow.

I think I was using the old spreadsheet on the last test.
0
JaseStAuthor Commented:
I have a couple other things that would be great to have done with my Applicant Status spreadsheet.

Would you be willing to take a look?
0
gowflowCommented:
it depends what !
gowflow
0
JaseStAuthor Commented:
It is an update to
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28156647.html

Need a sentence in the body of the email to say something different depending on the value in Col K
0
gowflowCommented:
Did you see the post I made on the previous question ?
gowflow
0
JaseStAuthor Commented:
That's okay if you can't or don't want to do it. I appreciate and am very, very grateful for all the help you gave me.
0
gowflowCommented:
I asked you a question: Did you see the post I made on the previous question AFTER you decided to delete it ?
gowflow
0
JaseStAuthor Commented:
no
0
gowflowCommented:
Well go check
gowflow
0
JaseStAuthor Commented:
it is deleted. Can't see it anymore
0
gowflowCommented:
0
JaseStAuthor Commented:
Alright. So what are you saying? You don't want to work on this particular question any more? Or you don't want to put in 'free time" and you are asking to get paid? Please be more clear.
0
gowflowCommented:
No question of being paid here. You decided to delete the question that I already worked on and put a lot of time I think it is only fair that you simply attribute 'some' points to this question to reward the effort put not simply go and delete it. That is what I meant.
gowflow
0
JaseStAuthor Commented:
oh sorry. As this question was over 4 months old I didn't think there was any solution given. I awarded you the points. Didn't know you had put a lot of time into it. My apologies
0
JaseStAuthor Commented:
did you get the points, gowflow?
0
gowflowCommented:
Yes thank you and I have put a message there.
Pls feel free to put link to any question you may need help with. I shall let you know upfront if I feel the question is too heavy and to break in smaller pieces to avoid waste of time.

For the previous question it was not clear from the start when you posted the question but working on it I discovered that it involved too much work that was not fair at the end.

Hope this clarifies the situation.
gowflow
0
JaseStAuthor Commented:
Not a problem, gowflow. I greatly appreciate your help.

I have a few other things that would be great to have done with my Applicant Status spreadsheet. Would you be willing to take a look?

I have to say I LOVE the functionality you have given me. It helps a lot.

The link to it is here:

http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28273579.html
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.