Solved

Improvements and Additions to previous question

Posted on 2011-10-01
33
257 Views
Last Modified: 2012-05-12
Improvements and Additions:

1. Import the value from the email to the WU-Staging-FBME sheet even if there is NO colon separating the label and the value IF the spelling meets one of the spelling options in the code AND even if the label and value are on the same
line as another label and value. Sometimes the Amount label and data are on the same line as Location:

2. If another email comes in after emails have been imported, AND  there is NO value in Col J, the numbering sequence in Col A continues sequentially from the last number entered in Col A. If there IS a Value in Col J, the
numbering sequence starts over with #1 in Col A and continues.

4. Sometimes a date is imported into Col C but nothing else. Not sure why that is happening, but a row should NOT be created IF there is no other values imported to Cols C, D, E, F OR G.

New:
5. Take the email address and the date of the email and put a value in Col M formatted like this: Jenxxxxx, - where xxxxx is the date of email. Example: Jen092911 (for Sept 29, 2011) The name preceding the date is calculated like this:

- if email is from, white@securenym.net it is Jenxxxxx
- if email is from, blizzard1980@hotmail.com, it is Adamxxxxx
- if from kong@securenym.net, it is Shawnxxxxx
- if info@holmsenterprises.com, it is Holmsxxxxx
- if it is from someone else not on the above list, it is their email addressxxxxx

- if for any of the above, there are two emails from the same day, then put a '-2' after the date. Example: Jen092911-2 of if 3 then a -3. I never get three, but just in case.

Put this value from Col M into every row imported from that email batch.

6.There almost always will be a card number somewhere indicated in the email body. If there is it will be a number 16 digits long (card numbers are all 16 digits and sometimes there are spaces or dashes separating them) then input that value into Col R, but only into the first row. If there isn't then proceed importing without it.

7. If the first digit of that 16 digit number is 4 then put the value 'EUR' in Col S.

8. If the first digit of the 16 digit number is 5, then put the value 'USD' in Col S.

There will be more to work on with this page, but I am trying to do it in sections.

Thank you!
0
Comment
Question by:JaseSt
  • 17
  • 16
33 Comments
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Hi JaseSt,

When you say
- if for any of the above, there are two emails from the same day, then put a '-2' after the date.
>> what do you mean by 'same day' is it the email date that is in Col C like if 2 wmails come that have the same email address and the same Col C date then the second refrence has a -2 ??

Pls clarify
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
Yes, exactly. The second batch from the same email address must be differentiated from the first batch that came in earlier that day - day being the date in Col C.
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
ok fine I need you to send me more sample emails especially ones that have same sender email in same day so I can test this routine and if you can give me say some 10 diffrent emails so I can make sure all the routines covers all 'known' cases as can see that these emails are hand written reason why lots of times there is misspelling like MTCN MCTN MTC etc.. RECEIVER RECIVIER RECIVR etc...
0
 

Author Comment

by:JaseSt
Comment Utility
Here are about 7 or so with all sorts of anomalies. And, I couldn't find two from one email address sent the same day. WU-Emails.zip
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
WOOOOOWWWW what a mix in the input I am amazed on how technical these operators are in submitting info !! They need a crystal ball to detect what they intend to submit not a program !!! Anyway working on it to improve detection keep throwing emails as you have even if they relate to last year or any all will help to cover all 'possibilities' as seems they are quite a few beyond any logical thought !
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
four more attached. WUEmails2.zip
0
 

Author Comment

by:JaseSt
Comment Utility
also, just noticed it's doing something strange. It is not skipping a row between imported emails, highlighting the second row, not the blank row and has missed an entire bottom entry from an email batch.

Something strange is happening with the import of the bottom entry in a batch. I'll have to experiment around with it a bit but wanted you to know what's happening so far.

0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
wait to see my version !!!! the one u had so many flops its not even funny !! Still finetuning very odd cases and should hv it almost ready by tomorrow
gowflow
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Well after good sweatting ... This version take cares of all cases except when the location and amount are on the same line. I will work to decript this. Meantime pls try this one and let me know your feedback. to install

1) Make a save as copy of the latest version of your visa file
2) open it and goto vba doubleclick on module1
3) click on left icon in the bottom window to view 1 sub at a time
4) select Sub ImportWesternUnion() and delete it
5) choose SELECT ALL in the below code window right click in the code and choose copy and paste it in module1 after any end sub.
Just so you know, you will be adding following items:
Sub ImportWesternUnion()
Function UpdateItemFound(rng As Range, elem As Variant) As Long
6) SAVE workbook and exit
7) Start the workbook (you may create a copy of the new workbook called test) and PLEASE try it with all kinds of emails and check results.

Pls let me know
gowflow
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


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

I = 1
Application.EnableEvents = False

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

    Set objMail = VItem
    ' use Instr here to check subject or body
    'MsgBox objMail.Subject
    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 "BLIZZARD1980@HOTMAIL.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

    
    If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 Then
        If rng Is Nothing Then
            Set rng = WS.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
            rng.Offset(1, 0).EntireRow.Insert
            WS.Range(rng.Offset(0, -1), rng.Offset(0, 39)).Interior.ColorIndex = 6
        Else
            rng.Offset(1, 0).EntireRow.Insert
            WS.Range(rng.Offset(1, -1), rng.Offset(1, 39)).Interior.ColorIndex = 6
            Set rng = rng.Offset(1, 0)
        End If
        arrRows = Split(Body, vbCrLf, , vbTextCompare)
        For Each elem In arrRows
            
            If InStr(1, elem, "AUSTIN STANDAGE") > 0 Then
                a = 1
            End If
    
            'Spot Card Number as 'CARD #'
            If InStr(1, UCase(elem), "CARD #", vbTextCompare) > 0 And CardNumber = "" Then
                CardNumber = Trim(Mid(elem, InStr(1, UCase(elem), "CARD #", vbTextCompare) + 6))
                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
                    Divider = ":"
                Else
                    If InStr(elem, ";") > 0 Then
                        Divider = ";"
                    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 = ""
            Fields = "MTCN|MTCN#|MCTN|MCTN#|MTCN #|MTC#|MTCN;"
            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 Then
                    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)
                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 "RECEIVER", "RECIEVER INFO", "RECEIVER NAME", "RECIEVER", "RECEVIER", "RECIVER", "RCVR"
                            rng = Trim(arrRow(1))
                        Case "SENDER", "ENDER"
                            rng.Offset(0, 3) = 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"
                            rng.Offset(0, 4) = Trim(arrRow(1))
                        Case "AMOUNT", "AMT", "AMOUNT SENT", "TOTAL", "TOTAL AMOUNT", "AOUNT", "MOUNT", "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
                            rng.Offset(0, 5) = CDbl(arrRow(1))
                            rng.Offset(0, 5).NumberFormat = "$#,##0.00;[Red]($#,##0.00)"
                        Case Else
                    End Select
                End If
            End If
            
        Next elem
    End If

Next VItem

'rng.Offset(1, 0).EntireRow.Insert
'WS.Range(rng.Offset(1, -1), rng.Offset(1, 33)).Interior.ColorIndex = 6
'rng.Offset(1, -1) = " "
Application.EnableEvents = True

'WS.UsedRange.EntireColumn.AutoFit
MsgBox ("Total of " & I & " Western Union detailed transfer imported successfully.")
End Sub


Function UpdateItemFound(rng As Range, elem As Variant) As Long
Dim I As Long, J As Long, K As Long, LenItem As Long
Dim Fields(5) As String
Dim Items, Item, TmpAmount
Dim ItemFound As String, Possibility As String

Fields(1) = "MTCN|MTCN#|MCTN|MCTN#|MTCN #|MTC#|MTCN;"
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"
Fields(4) = "AMOUNT|AMT|AMOUNT SENT|TOTAL|TOTAL AMOUNT|AOUNT|MOUNT|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 InStr(1, ItemFound, I, vbTextCompare) = 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 InStr(1, elem, ":", vbTextCompare) > 0 Then
                        Item = Mid(elem, InStr(1, elem, ":", vbTextCompare))
                    Else
                        Item = Trim(Mid(elem, Len(Possibility) + 1))
                    End If
                    rng.Offset(0, 2) = Trim(Format(Item, "@"))
                    ItemFound = ItemFound & Format(I)
                    
                Case 2  'Reciever
                    If InStr(1, elem, ":", vbTextCompare) > 0 Then
                        Item = Mid(elem, InStr(1, elem, ":", vbTextCompare))
                    Else
                        Item = Trim(Mid(elem, Len(Possibility) + 1))
                    End If
                    rng = Trim(Item)
                    ItemFound = ItemFound & Format(I)
                    
                Case 3  'Location
                    If InStr(1, elem, ":", vbTextCompare) > 0 Then
                        Item = Mid(elem, InStr(1, elem, ":", vbTextCompare))
                    Else
                        Item = Trim(Mid(elem, Len(Possibility) + 1))
                    End If
                    rng.Offset(0, 4) = Trim(Item)
                    ItemFound = ItemFound & Format(I)
                    
                                    
                Case 4  'Amount
                    If InStr(1, elem, ":", vbTextCompare) > 0 Then
                        Item = Mid(elem, InStr(1, elem, ":", vbTextCompare))
                    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)"
                    ItemFound = ItemFound & Format(I)
                
                Case 5  'Sender
                    If InStr(1, elem, ":", vbTextCompare) > 0 Then
                        Item = Mid(elem, InStr(1, elem, ":", vbTextCompare))
                    Else
                        Item = Trim(Mid(elem, Len(Possibility) + 1))
                    End If
                    rng.Offset(0, 3) = Trim(Item)
                    ItemFound = ItemFound & Format(I)
                    
            End Select
  End If
Next I
If ItemFound <> "" Then
    UpdateItemFound = True
Else
    UpdateItemFound = False
End If
End Function

Open in new window

0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Here it is !!!!
With this revised version of both
Sub ImportWesternUnion()
and
Function UpdateItemFound(rng As Range, elem As Variant) As Long

with the emails examples you supplied to me I have an error ratio of the Amount item of 1 over 124 which corespond to 0.8% error ratio. If this is satissfactory to you then this is my final version. if not pls let me know.

Delete both sub and function mentioned form module1 after saving a new version of the workbook and copy the below code in module1 after any end sub. save and exit the new workbook and try it and let me know.
gowflow
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


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

I = 1
Application.EnableEvents = False

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

    Set objMail = VItem
    ' use Instr here to check subject or body
    'MsgBox objMail.Subject
    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 "BLIZZARD1980@HOTMAIL.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

    
    If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 Then
        If rng Is Nothing Then
            Set rng = WS.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
            rng.Offset(1, 0).EntireRow.Insert
            WS.Range(rng.Offset(0, -1), rng.Offset(0, 39)).Interior.ColorIndex = 6
        Else
            rng.Offset(1, 0).EntireRow.Insert
            WS.Range(rng.Offset(1, -1), rng.Offset(1, 39)).Interior.ColorIndex = 6
            Set rng = rng.Offset(1, 0)
        End If
        arrRows = Split(Body, vbCrLf, , vbTextCompare)
        For Each elem In arrRows
            
            If InStr(1, elem, "Ashleigh Walck") > 0 Then
                a = 1
            End If
    
            'Spot Card Number as 'CARD #'
            If InStr(1, UCase(elem), "CARD #", vbTextCompare) > 0 And CardNumber = "" Then
                CardNumber = Trim(Mid(elem, InStr(1, UCase(elem), "CARD #", vbTextCompare) + 6))
                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 = ""
            Fields = "MTCN|MTCN#|MCTN|MCTN#|MTCN #|MTC#|MTCN;"
            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 Then
                    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)
                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 "RECEIVER", "RECIEVER INFO", "RECEIVER NAME", "RECIEVER", "RECEVIER", "RECIVER", "RCVR"
                            rng = Trim(arrRow(1))
                        Case "SENDER", "ENDER"
                            rng.Offset(0, 3) = 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"
                            rng.Offset(0, 4) = Trim(arrRow(1))
                        Case "AMOUNT", "AMT", "AMOUNT SENT", "TOTAL", "TOTAL AMOUNT", "AOUNT", "MOUNT", "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
                            rng.Offset(0, 5) = CDbl(arrRow(1))
                            rng.Offset(0, 5).NumberFormat = "$#,##0.00;[Red]($#,##0.00)"
                        Case Else
                    End Select
                    
                End If
            End If
            
        Next elem
    End If

Next VItem

Application.EnableEvents = True

'WS.UsedRange.EntireColumn.AutoFit
MsgBox ("Total of " & I & " Western Union detailed transfer imported successfully.")
End Sub


Function UpdateItemFound(rng As Range, elem As Variant) 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

Fields(1) = "MTCN|MTCN#|MCTN|MCTN#|MTCN #|MTC#|MTCN;"
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"
Fields(4) = "AMOUNT|AMT|AMOUNT SENT|TOTAL|TOTAL AMOUNT|AOUNT|MOUNT|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

0
 

Author Comment

by:JaseSt
Comment Utility
got an 'independent' wu email - one that is not on the list - and when trying to import came up with an error: run time error 13 with this highlighted in yellow: rng.Offset(0, 5) = CDbl(arrRow(1))

Attached is the email and a screenshot of the import to the spreadsheet. A few things to note:

1. In Col A, it started numbering over from 1 even though there was no value in Col J.
"2. If another email comes in after emails have been imported, AND  there is NO value in Col J, the numbering sequence in Col A continues sequentially from the last number entered in Col A. If there IS a Value in Col J, the numbering sequence starts over with #1 in Col A and continues."

2. It obviously missed some data to import and created two more rows when there is only one batch to import. HOWEVER, there were labels in this email as you can see so that is the reason. Be good to cover that situation when they are responding to an email I sent them on proper format. screenshot RE-Document-Passeport-and-Bill-2.msg
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
OK will fix numbering for Col J just noticed your original post but had so many priorities to fix import correctly that this one sliped by.

for the attached email am checking it right now.

Any feedback from the whole import !!! ? I just read neg comments !!! :(
gowflow.
0
 

Author Comment

by:JaseSt
Comment Utility
sorry, it worked fantastic, just was trying to give you the meat instead of the whole story right now.  As you can see it separated the entries just fine, perfectly put in the email address or ID and created a yellow empty row. Great work, so far! thank you!!!

On another note, having an issue with the Mastercard spreadsheet. For some reason the Import Emails to Spreadsheet, red button, increased in size all by itself! How? Why? I have no idea.
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
ok fine

here is the code to replace the old sub that will fix counting depending on col J
Do you want me to remove blank lines ? This I do not check !

For mastercard
I suggest you post a question and put the link here

gowflow
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


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
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 Western Union - Items: " & I & " " & VItem.SenderEmailAddress & " " & VItem
    CRow = CRow + 1

    Set objMail = VItem
    ' use Instr here to check subject or body
    'MsgBox objMail.Subject
    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 "BLIZZARD1980@HOTMAIL.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

    
    If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 Then
        If rng Is Nothing Then
            Set rng = WS.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
            rng.Offset(1, 0).EntireRow.Insert
            WS.Range(rng.Offset(0, -1), rng.Offset(0, 39)).Interior.ColorIndex = 6
        Else
            rng.Offset(1, 0).EntireRow.Insert
            WS.Range(rng.Offset(1, -1), rng.Offset(1, 39)).Interior.ColorIndex = 6
            Set rng = rng.Offset(1, 0)
        End If
        arrRows = Split(Body, vbCrLf, , vbTextCompare)
        For Each elem In arrRows
            
            If InStr(1, elem, "Ashleigh Walck") > 0 Then
                a = 1
            End If
    
            'Spot Card Number as 'CARD #'
            If InStr(1, UCase(elem), "CARD #", vbTextCompare) > 0 And CardNumber = "" Then
                CardNumber = Trim(Mid(elem, InStr(1, UCase(elem), "CARD #", vbTextCompare) + 6))
                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 = ""
            Fields = "MTCN|MTCN#|MCTN|MCTN#|MTCN #|MTC#|MTCN;"
            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 Then
                    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)
                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 "RECEIVER", "RECIEVER INFO", "RECEIVER NAME", "RECIEVER", "RECEVIER", "RECIVER", "RCVR"
                            rng = Trim(arrRow(1))
                        Case "SENDER", "ENDER"
                            rng.Offset(0, 3) = 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"
                            rng.Offset(0, 4) = Trim(arrRow(1))
                        Case "AMOUNT", "AMT", "AMOUNT SENT", "TOTAL", "TOTAL AMOUNT", "AOUNT", "MOUNT", "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 Else
                    End Select
                    
                End If
            End If
            
        Next elem
    End If

Next VItem

Application.EnableEvents = True

'WS.UsedRange.EntireColumn.AutoFit
MsgBox ("Total of " & I & " Western Union detailed transfer imported successfully.")
End Sub

Open in new window

0
 

Author Comment

by:JaseSt
Comment Utility
thank you. I'll try it out soon. What do you mean by 'removing blank lines'? If you mean the empty, yellow highlighted rows, then no. I want those as they separate email batches, however, they should not have any numbers in Col A.

If you're meaning the no values after the labels as in the attached email, then yes. We do not want to import labels that have no data.

Maybe I'm not understanding?
0
 

Author Comment

by:JaseSt
Comment Utility
Well, the numbering system in Col A worked, but in the email previously attached, above, this time it skipped some content. Not sure why because the labels look fine and have colons as well. imported
0
Windows Server 2016: All you need to know

Learn about Hyper-V features that increase functionality and usability of Microsoft Windows Server 2016. Also, throughout this eBook, you’ll find some basic PowerShell examples that will help you leverage the scripts in your environments!

 
LVL 29

Expert Comment

by:gowflow
Comment Utility
This should be the perfect format !
-------------------
MTCN#:
Receiver:
Sender:
location:
Amount:
----------------

Notce the doted start and end (they are not there in the last message. Notice SENDER and SENDER LOCATION you have SENDER that is similar in both and create issue. I have made so many exceptions but if your going ahead and sending a msg format you might as well send a good one like the one above also notice no blank lines in between !!!!

Ican't beleive you send them THIS !!!
>>>
When submitting Western Union wire notices please use the exact format below.
Note each label is on its seperate line followed by a colon. Please use this format
and layout.  
 
MTCN#:
RECEIVER:
SENDER:  
SENDER LOCATION:
AMOUNT:

>>>
As if your not aware of the format !!!
:( Sorry I will not fix the last message enough fiddling around
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
gowflow, there were no blank lines when I sent them the format. emails often times reformat spacing and that is what happened with this one. So, why don't you tell me what format you want and I'll let our customers know and hopefully they will follow it, but my experience is that there is more often than not, discrepancies with what they send me.
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
THIS IS THE FORMAT they should respect dashed line at beg and dashed line at the end and the ":" after each label then a space then what they want to fill and no lines in between lables
-------------------
MTCN#:
Receiver:
Sender:
location:
Amount:
----------------


gowflow
0
 
LVL 29

Accepted Solution

by:
gowflow earned 500 total points
Comment Utility
This version will remove blank lines as well (not the yellow lines but lines that have a number in col A and a date only and the rest of fields empty. delete the existing sub and replace it by this one.
gowflow
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


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
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 Western Union - Items: " & I & " " & VItem.SenderEmailAddress & " " & VItem
    CRow = CRow + 1

    Set objMail = VItem
    ' use Instr here to check subject or body
    'MsgBox objMail.Subject
    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 "BLIZZARD1980@HOTMAIL.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

    
    If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 Then
        If rng Is Nothing Then
            Set rng = WS.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
            rng.Offset(1, 0).EntireRow.Insert
            WS.Range(rng.Offset(0, -1), rng.Offset(0, 39)).Interior.ColorIndex = 6
        Else
            rng.Offset(1, 0).EntireRow.Insert
            WS.Range(rng.Offset(1, -1), rng.Offset(1, 39)).Interior.ColorIndex = 6
            Set rng = rng.Offset(1, 0)
        End If
        arrRows = Split(Body, vbCrLf, , vbTextCompare)
        For Each elem In arrRows
            
            If InStr(1, elem, "Ashleigh Walck") > 0 Then
                a = 1
            End If
    
            'Spot Card Number as 'CARD #'
            If InStr(1, UCase(elem), "CARD #", vbTextCompare) > 0 And CardNumber = "" Then
                CardNumber = Trim(Mid(elem, InStr(1, UCase(elem), "CARD #", vbTextCompare) + 6))
                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 = ""
            Fields = "MTCN|MTCN#|MCTN|MCTN#|MTCN #|MTC#|MTCN;"
            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 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)
                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 "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"
                            rng.Offset(0, 4) = Trim(arrRow(1))
                        Case "AMOUNT", "AMT", "AMOUNT SENT", "TOTAL", "TOTAL AMOUNT", "AOUNT", "MOUNT", "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

Next VItem

Application.EnableEvents = True

'WS.UsedRange.EntireColumn.AutoFit
MsgBox ("Total of " & I & " Western Union detailed transfer imported successfully.")
End Sub

Open in new window

0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Ooops forgot a major one too in the format here it is again they should not forget the work CARD followed by # just stuck to it 'CARD#' then a space then the 16 digit card number.

CARD# xxxxxxxxxxxxxxxxxxx

-------------------
MTCN#:
Receiver:
Sender:
location:
Amount:
----------------

gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
ok, I let all my senders know of the above exact email format and we'll give it a few days to try it out and then, hopefully close this one out. thank you.
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
ok

what about your mastercard issue is it resolved?
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Hope to hear from your testing soon !!!

By the way don't be afraid to throw at me all kind of questions ... I hope you don't use me only for though and long ones as I noticed you asked questions on EE that are good and quick !!!
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
Will do on the smaller projects as I think of them.

In regards to the latest, well.... it worked for the most part except it duplicated the card number across the top row forever as can be seen in the attached screenshot. And didn't import an amount where it was formatted as: AMMOUNT: 485 $

And this is after giving them the template to use. Not sure if the $ caused it or the misspelling.
Also, don't care for the border on that top row, unless all of the rows get borders. Not sure why the top row is also aligned left. Not a biggie, however. Other than the above worked very nicely. import
0
 

Author Comment

by:JaseSt
Comment Utility
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
re the problem you got
1) I need the email that made this problem
2) what do you mean by top row ? the first row to import ? is it for each email ???

gowflow
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
You have not replied to above thread did you fix your problem ??
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
Sorry, kind of forgot about it. Seems to work just fine, but sometimes puts a yellow background color on the first row imported. Not a big deal because most of the time it doesn't. Haven't seen the problem since. Going to consider this one closed, but if have issues may contact you about it. Thanks again.
0
 

Author Closing Comment

by:JaseSt
Comment Utility
This code will most likely need to be modified as the page the email is being imported into has a number of functions I need it to do, which I will submit as related questions.

Great work so far, gowflow. Thanks once again.
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Your welcome and tks for the grade pls go ahead with what has to follow
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
0

Featured Post

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Granting full access permission allows users to access mailboxes present in their database. By giving full access permission one can open and read the content of any mailbox but cannot send emails from that mailbox.
Outlook Free & Paid Tools
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

743 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

14 Experts available now in Live!

Get 1:1 Help Now