asked on

Tweak to importing Western Union emails to WU-Staging-FBME sheet

gowflow,

You created a function that imports Western Union emails that kicks off when I click the "Import WU/MG Emails" button.

For some reason it is not importing the card numbers for two emails that I regularly get WU emails from.

For all the emails that are imported to the spreadsheet with this function that have a sixteen digit card number, starting with 438101360 I need the whole card number inserted into col R.

I'm including the code below because I have added more misspellings to fields that you didn't have in your original code and I might have changed an email address:

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
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 Then

'---> Set Type of Email for future use
If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 Then eType = "WU"
If InStr(1, UCase(Body), "MG", vbTextCompare) > 0 Then eType = "MG"

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
'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

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 = ""
If eType = "WU" Then Fields = "MTCN|MTCN#|MCTN|MCTN#|MTCN #|MTC#|MTCN;"
If eType = "MG" Then Fields = "MG|MG#|MG #|MG;"

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, 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;"
'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"
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

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

Jacques Geday

I read this question couple of times and I dont understand what you mean by:

quote
I'm including the code below because I have added more misspellings to fields that you didn't have in your original code and I might have changed an email address:
unquote

Did you modify the code and inserted things ??? and what is exactly requested by this question ? I am puzzeled here.
gowflow

JaseSt

ASKER

Yes I modified the code by adding some misspellings like in this section:

Case "AMOUNT", "AMT", "AMOUNT SENT", "TOTAL", "TOTAL AMOUNT", "AOUNT", "MOUNT", "AMMOUNT", "AMNT", "AMOUNT $"

I added the "AMMOUNT",

I also changed an email address to:
Case "LENNOX@SECURENYM.NET"

The code you wrote imports the credit card number into Col R, but for some reason it doesn't do it for all the emails listed in the above code. I need it to, so I am suggesting that in these imported emails put insert a value into Col R when there is number, starting with 438101360 in the email.

Does that make sense?

Jacques Geday

can you pls post the emails thaat are not imported and 1 or 2 that are imported correctly specifying which is and which is not so I can troubleshoot the issue ?
you can save them as .msg and attach them in a zip file.
Rgds/gowflow

JaseSt

ASKER

Example emails attached.Emails.zip

Jacques Geday

Well 2 things:

1) The changes you made re the new email address and the AMMOUNT are fine in that subroutine. You need an update in an other routine which I am inserting here below. Please replace in the sub UpdateItemFound the following line:

Fields(4) = "AMOUNT|AMT|AMOUNT SENT|TOTAL|TOTAL AMOUNT|AOUNT|MOUNT|AMNT|AMOUNT $"

By the following Line:
Fields(4) = "AMOUNT|AMT|AMOUNT SENT|TOTAL|TOTAL AMOUNT|AOUNT|MOUNT|AMMOUNT|AMNT|AMOUNT $"

2) In both emails with subject
Shawn 112112-1 $2235
JEN PAYMENTS 11/21 **JEN112112** ( $6 ,760 USD / € 5,274 EU)

you have both MTCN and MG in each of these emails. If I recall well, you had mentioned when we coded MG that the emails would come 'EITHER' MTCN or EITHER MG but not both in same email reason why it is not updating correctly. (This is a quick assumption of me as noticed that the first email it picked concluded of MTCN whil the first record was MG and by the way it determis the type of the email it does not take into concideration that there may be a mixture of these in the same email.

Does this chaged now ??? or these were odd emails and can be corrected so the situation does not reapeat in the future ???

Pls let me know your comments and what you need at this point.
gowflow

Jacques Geday

Here it is JaseSt,

I have updated the subroutine ImportWesternUnion() to take care of emails with a mix as well. Please do the following after you have corrected the sub UpdateItemFound like advised in my previous post.

1) Make a new copy of the latest Visa file (the one after the update here mentioned above) and give it a new name.
2) Open it and goto VBA and doubleclick on module1
3) Choose to view 1 sub at a time by clicking on the bottom left icon.
4) Choose the sub ImportWesternUnion() and delete it.
5) Copy the below new sub 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
    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 Then
        
        '---> Set Type of Email for future use
        If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 And InStr(1, UCase(Body), "MG", 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 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 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 = ""
            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 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;"
            
            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;"
                            '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"
                            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

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

Open in new window

5) SAVE and Exit the workbook.
6) Open it and run the button Import WU/MG Emails.

Pls check it and let me know.
gowflow

JaseSt

ASKER

nope, didn't work.

I just tried importing the attached email and no card number imported

card-load-request-1125--1385.msg

ASKER CERTIFIED SOLUTION

Jacques Geday

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

JaseSt

ASKER

Hi gowflow. I have only received one email to test this on and it worked but want to test it on a few more before I accept it. Should get more emails soon.

Thanks for your efforts!

JaseSt

ASKER

Tested on emails that didn't work before and now seems to work perfectly, gowflow.

Thank you!

Have another dealing with the solution you gave that is initiated when
the button '2-Generate WU File' is clicked on the Mastercard workbook if you're willing.
Let me know and I'll put the link here.

Jacques Geday

yes pls go ahead
gowflow

JaseSt

ASKER

ok, thanks - here it is:

https://www.experts-exchange.com/questions/27948752/Tweak-of-Creating-WU-Spreadsheet.html

You'll probably have questions.