Solved

Importing content from Outlook 2010 into Excel 2010 Spreadsheet

Posted on 2014-04-13
12
324 Views
Last Modified: 2014-04-17
This question is based on a solution already provided:
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_27943128.html and attached is the code.

For some reason I am now getting an error that states:
"Run-time error '91': Object variable or With Block variable not set"

And gives this as the yellow highlighted code:
wsMain.Range("L" & CRow) = "Import Western Union - FMonitor: " & objFolderToMonitor

I recently got a new hard drive, replacing the older and not sure why it's failing now.

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

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


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

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

Dim VItem As Outlook.MailItem

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

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

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

Application.EnableEvents = False

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

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

Application.EnableEvents = True

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

End Sub

Open in new window

0
Comment
Question by:mabehr
  • 7
  • 5
12 Comments
 
LVL 20

Expert Comment

by:ltlbearand3
ID: 39998943
I don't see in your code where you set objFolderToMonitor.  Perhaps when you received the new hard drive, it was not configured exactly the same and this object points to a location that no longer exists?  Check your code where you set that object.  You can also step through your code and hover over each item on that line to get a sense of what may be wrong.  First, thought I would check where you set objFolderToMonitor.  If you still need help, please post that section of code.  Thanks.
0
 

Author Comment

by:mabehr
ID: 39998952
Thanks ltlbearand3 but how do I find where objFolderToMonitor is set?
0
 
LVL 20

Expert Comment

by:ltlbearand3
ID: 39999893
It appears this code is in Excel.  If so, can you possibly post the Excel workbook?  If not, you can search through the code for this value and find a line that probably starts set objFolderToMonitor.  Press ALT-F11 for the code windows.  Then choose Edit >> Find from the Menu (or Cntrl-F).  Change the search option to entire project and then search for objFolderToMonitor.  Then you can paste the section of code you find here for us to review.
0
 

Author Comment

by:mabehr
ID: 40000700
Doing as you suggested I found multiple instances of it in the attached module.
Global Const APP_CATEGORY = "Software JG"
Global Const APPNAME = "ImportEmails"
Global WSVisa As Worksheet
Global wsMain As Worksheet

Global myolApp As Outlook.Application
Global gstFolderToMonitor As String
Global gstFolderToTransfer As String
Global gstFolderWesternUnion As String
Global gstFolderVisaFile As String
Global gstFolderMonthlyTotalsFile As String
Global gstGenerateWUName As String
Global gstGenerateWUEmail As String
Global gstGenerateVisaName As String
Global gstGenerateVisaEmail As String

Global objOutlook As New Outlook.Application
Global objNameSpace As Outlook.Namespace
Global objFolders As Outlook.Folders
Global objFolder As MAPIFolder
Global InboxFolder As MAPIFolder

Global objFolderToMonitor As MAPIFolder
Global objFolderToTransfer As MAPIFolder

Global VisaItems As Outlook.Items
Global objMail As Outlook.MailItem
Global StartPGM As Boolean
Global CRow As Long

Private Sub ADODB_Connection()
    Dim cnt As New ADODB.Connection
    Dim rst As New ADODB.Recordset
     
    cnt.Open "Provider=Microsoft.Ace.OLEDB.12.0; Persist Security Info = False;" & _
    "Data Source=T:\Trad\data\Quote Log.accdb;"
    rst.Open "Select * From CaseNum", cnt
    Sheets("List").Range("a1").CurrentRegion.ClearContents
    Sheets("List").Range("A1").CopyFromRecordset rst
    rst.Close
    cnt.Close
End Sub


Sub CrossCheckVisaAndDB()
On Error GoTo ErrCross

Dim WS As Worksheet
Dim MaxRow As Long, I As Long, J As Long, K As Long, L As Long
Dim CnctString As String, DBName As String, CCNumber As String, CustNumber As String
Dim SQL As String, MyFilter As String
Dim CustName As String
Dim LastName
Dim FoundIT As Boolean
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset
     
Set WS = Sheets("Visa Consolidated")
MaxRow = WS.Rows(WS.Rows.Count).End(xlUp).Row

DBName = gstFolderVisaFile & "CustomerDatabaseDec14-11.accdb"
CnctString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DBName & ";Persist Security Info=False;"
SQL = "SELECT * FROM [Customer List]"

cnt.Open CnctString
rst.CursorType = adOpenStatic
rst.Open SQL, cnt
rst.MoveFirst

For I = 2 To MaxRow
    If WS.Cells(I, "B").Interior.ColorIndex <> 4 Then
        CustName = WS.Cells(I, "A")
        CCNumber = Left(Format(WS.Cells(I, "C"), "#"), 15)
        CustNumber = Format(WS.Cells(I, "B"), "#")
        FoundIT = False
            For K = 0 To rst.RecordCount - 1
                If Not IsNull(rst.Fields("Last Name")) Then
                    LastName = Split(UCase(Trim(rst.Fields("Last Name"))), " ")
                    For L = 0 To UBound(LastName)
                        If Left(rst.Fields("Credit Card Number"), 15) = CCNumber And _
                            rst.Fields("FBME Cust Number") = CustNumber And _
                            InStr(1, UCase(Trim(CustName)), LastName(L)) <> 0 Then
                            WS.Cells(I, "B").Interior.ColorIndex = 4
                            J = J + 1
                            FoundIT = True
                            Exit For
                        End If
                    Next L
                    If FoundIT Then
                        Exit For
                    Else
                        rst.MoveNext
                    End If
                Else
                    rst.MoveNext
                End If
            Next K
    
        rst.MoveFirst
    End If
Next I

MsgBox ("From a total of " & MaxRow - 1 & " Items in Sheet Visa consolidated, " & J & " was Cross-Checked and found similar in Database.")
rst.Close
cnt.Close
Set rst = Nothing
Set cnt = Nothing

ErrCrossEnd:
Exit Sub

ErrCross:
MsgBox (Error(Err))
'Resume
MsgBox ("Routine encountered an error at row " & I & " and possibly caused by item# " & K & " in the database and will exit. Pls check data and start again.")
GoTo ErrCrossEnd

End Sub





Sub GenerateVisaFile()
Dim WS As Worksheet
Dim WSS As Worksheet
Dim NewWS As Worksheet
Dim MaxRow As Long, I As Long, J As Long, K As Long, DateCol As Long
Dim NewWb As Workbook
Dim NewWorkB As String
Dim TDate As String, Todate As Date, SDate As Date

If gstFolderVisaFile = "" Then
    MsgBox ("You need to select a destination folder to store the Create Visa File created. Please go to Sheet 'Main' and select a folder before proceeding further.")
    Exit Sub
Else
    If MsgBox("This process will create a new workbook with today's date and load in it all records in sheets 'Visa Consolidated' that bear today's date." & Chr(10) & Chr(10) _
        & "Are you ready to start this process ?", vbQuestion + vbYesNo, "Create Visa File") = vbYes Then
        
        Set WS = Sheets("Visa Consolidated")
        
        '---> new procedure for opening the default blank form sent by the bank set by gowflow on 14/1/2012
        On Error Resume Next
        Application.AutomationSecurity = msoAutomationSecurityForceDisable
        Application.EnableEvents = False
        Set NewWb = Workbooks.Open(Filename:=gstFolderVisaFile & "BlankVisaSubmissionSheet.xls")
        'Application.AutomationSecurity = msoAutomationSecurityLow
        Application.EnableEvents = True
        If Err <> 0 Then
            MsgBox ("Deafault blank file 'BlankVisaSubmissionSheet.xls' was not found please create it or adjust Visa file folder location then re-start this procedure.")
            Exit Sub
        End If
        On Error GoTo 0
        
        'Set NewWb = Workbooks.Add
        Set NewWS = NewWb.ActiveSheet
        

        '---> Setup Next Date Visa file that should be on a working day
        '---> If Date is Saturday or Sunday it should go to Next Monday
        '---> or else on Next Day
        If Weekday(Now + 1) = 7 Then
            SDate = Now + 3
        Else
            If Weekday(Now + 1) = 1 Then
                SDate = Now + 2
            Else
                SDate = Now + 1
            End If
        End If
        
        'Disabled Naming of the sheet as we are using the bank workbook and
        'sheet name could be meaningful to them.
        'NewWS.Name = Format(SDate, "mm-dd-yyyy")
        Application.EnableEvents = False
        NewWb.SaveAs Filename:=gstFolderVisaFile & "Visa - Sovereign sm" & Format(SDate, "Mmmdd-yy") & ".xls", FileFormat:=xlExcel8
        Application.EnableEvents = True
        NewWorkB = NewWb.Name
        

        '---> Modified to adapt to file submited by the bank updated by gowflow on 14/1/2012
        J = 3
        K = 1
        'Date Col F
        DateCol = 6
        TDate = Format(Now, "mm/dd/yyyy")
        Todate = DateValue(TDate) + 1
        MaxRow = WS.UsedRange.Rows.Count
        WS.UsedRange.AutoFilter Field:=DateCol, Criteria1:=">=" & TDate, Operator:=xlAnd, Criteria2:="<" & Todate
        
        For I = 2 To MaxRow
            If WS.Range(I & ":" & I).EntireRow.Hidden = False Then
                
                If J = 1 Then
                    '---> Create the Header for the First Time
                    'Customer Identifier Currency    Amount  Merchant Reference
                    'disabled by gowflow on 14/1/2012 as we are now openeing the blank
                    'worksheet that is sent from the bank that has already a header row
                    NewWS.Cells(J, "A") = "Customer Identifier"
                    NewWS.Cells(J, "B") = "Currency"
                    NewWS.Cells(J, "C") = "Amount"
                    NewWS.Cells(J, "D") = "Merchant Reference"
                    NewWS.Range(J & ":" & J).Font.Bold = True
                Else
                    '---> Copy Col B from Visa to Col A of New File
                    NewWS.Cells(J, "A") = WS.Cells(I, "B")
                    
                    '---> Copy Col E from Visa to Col C of New File
                    NewWS.Cells(J, "C") = Format(WS.Cells(I, "E"), "€#,###.00")
                    
                    '---> Put EUR to Col B of New File
                    NewWS.Cells(J, "B") = "EUR"
                    
                    '---> Insert 'smcurrentYearMonthDate#' Visa to Col D of New File
                    NewWS.Cells(J, "D") = "sm" & Format(Year(SDate), "0000") & Format(Month(SDate), "00") & Format(Day(SDate), "00") & J - 1
                End If
                J = J + 1
            End If
        Next I
        WS.ShowAllData
        WS.AutoFilterMode = False
       
        With NewWS.Columns("A:D")
           .EntireColumn.AutoFit
           .HorizontalAlignment = xlCenter
        End With
        
        NewWb.Save
                 
        '---> Check if there was data in the file if yes the update variables to send file if no kill the file saved
        MaxRow = NewWS.UsedRange.Rows.Count
        
        If MaxRow > 2 Then
            gstGenerateVisaName = NewWb.FullName
            gstGenerateVisaEmail = ""
            X = MsgBox("Workbook: '" & NewWorkB & "' has been created successfully. Please check workbook to ensure all data is accurate. After all modifications done please ensure file is saved to proceed to Next Step - [Generate Visa Email]", vbInformation, "Generate Visa File")
        Else
            Application.DisplayAlerts = False
            NewWb.Close savechanges:=False
            Kill NewWorkB
            Application.DisplayAlerts = True
            gstGenerateVisaName = ""
            gstGenerateVisaEmail = ""
            MsgBox ("No Records were found ! nothing to Export.")
        End If
    End If
End If
End Sub







Function ImportData5New(Body As String, ByVal RDate As Date, Row As Long) As String
On Error GoTo Errhandler25
Dim WS As Worksheet
Dim CC As String
Dim CName As String
Dim Cur As String
Dim Amt As Double
Dim Tmp As String
Dim MaxRow As Long, MaxRowH As Long

tmpa = Split(Body, Chr(10))

For I = 0 To UBound(tmpa)
    'Find CC and CName
    st = InStr(1, tmpa(I), "From:", vbTextCompare)
    If st <> 0 Then
        If Not IsNumeric(Mid(tmpa(I), st + 6, 1)) Or Mid(tmpa(I), st + 6, 1) <> "5" Then
            If IsNumeric(Mid(tmpa(I), st + 6, 3)) Then
                ImportData5New = Mid(tmpa(I), st + 6)
                Exit Function
            Else
                'Disabled the Exit Function to Trap HMF and Victor Emails
                ImportData5New = Mid(tmpa(I), st + 6)
            End If
        Else
            tmpb = Split(Mid(tmpa(I), st + 6, InStr(st, tmpa(I), Chr(13), vbBinaryCompare)), " ")
            For J = 0 To UBound(tmpb)
                If IsNumeric(tmpb(J)) Then
                    CC = CC & tmpb(J)
                Else
                    Exit For
                End If
            Next J
            
            For K = J To UBound(tmpb)
                CName = CName & tmpb(K) & " "
            Next K
            CName = RTrim(CName)
        End If
    End If
    
    'Find Curency, Amt
    st = InStr(1, tmpa(I), "Amount:", vbTextCompare)
    If st <> 0 Then
        tmpb = Split(Mid(tmpa(I), st + 8, InStr(st, tmpa(I), Chr(13), vbBinaryCompare)), " ")
        If UBound(tmpb) = 1 Then
            Cur = tmpb(0)
            Amt = tmpb(1)
        End If
    End If
Next I

'Save to Excel Tab
MsgBox ("looking for sheet to update")
If ImportData5New = "" Then
    'Disabled as applicable in Mastercard for finding the Credit Card number realted to the customer
    'ShtName = FindExcelTab(CC)
    
    'Exit this function as we are only intrested in updating HMF Visa and Victor Group Sheets ONLY
    ImportData5New = "Item Not Found"
    Exit Function
Else
    
    If ImportData5New <> "" And InStr(1, ImportData5New, Chr(13)) <> 0 Then ImportData5New = Trim(Left(ImportData5New, InStr(1, ImportData5New, Chr(13)) - 1))
    If UCase(ImportData5New) = "4VISA HMF" Then
        ShtName = "HMF Visa"
    Else
        If UCase(ImportData5New) = "VICTOR GROUP" Then
            ShtName = "Victor Group"
        Else
            ShtName = ImportData5New
            'Exit Function
        End If
    End If
  
End If


'Application.ScreenUpdating = False
'Look for the sheet
FoundSheet = False

For Each WS In ThisWorkbook.Worksheets
    If UCase(WS.Name) = UCase(ShtName) Then
        FoundSheet = True
        Exit For
    End If
Next WS

If FoundSheet = False Or ShtName = "" Then
    ImportData5New = "Sheet: " & CName & " Not Found"
    Exit Function
Else

With Sheets(UCase(ShtName))
    .Activate
    '.UsedRange.Select
    MaxRow = .UsedRange.Rows.Count + 1
    MaxRowH = .Range("H:H").Rows(.Range("H:H").Rows.Count).End(xlUp).Row
    
    If ImportData5New = "" Then
        .Cells(MaxRow, "F") = Amt
    Else
        .Cells(MaxRow, "A") = RDate
        .Cells(MaxRow, "F") = Amt
        If UCase(ShtName) <> "HMF VISA" Then
            .Cells(MaxRow, "G").Formula = "=IF(F" & MaxRow & "*1.85%<20,20,F" & MaxRow & "*1.85%)"
        End If
        .Range("H" & MaxRowH & ":H" & MaxRow).FillDown
        .Range("H" & MaxRowH + 1 & ":H" & MaxRow).Interior.ColorIndex = 0
        .Cells(MaxRow, "H").Formula = "=H" & MaxRowH & "+F" & MaxRow & "-G" & MaxRow & "-J" & MaxRow
        .Cells(MaxRow, "K") = RDate
        If UCase(ShtName) <> "HMF VISA" Then
            .Cells(MaxRow, "L").Formula = "=G" & MaxRow
        End If
        .Range("A" & MaxRow & ":L" & MaxRow).Interior.ColorIndex = 4
   End If
    If CName = "" Then CName = ShtName
    wsMain.Range("L" & CRow) = "Import Data : <" & CName & " " & RDate
    CRow = CRow + 1
End With
    ImportData5New = ""

'Application.ScreenUpdating = True
'Application.EnableEvents = True

End If


Exit Function

Errhandler25:
MsgBox (Error(Err))
wsMain.Range("L" & CRow) = "Import Data - Error: <" & Error(Err) & "> Item " & CName & " " & RDate
CRow = CRow + 1

Resume Next

End Function

Sub ImportWUConfirmedAmts()
Dim WS As Worksheet
Dim WSWU As Worksheet

Dim WB As Workbook
Dim I As Long, J As Long
Dim MaxRowWU As Long, MaxRowWUBalance As Long
Dim Rng As Range
Dim TConfirmed As Double, TColG As Double, TColH As Double
Dim WUFile As String, WUDate As String
Dim C

If MsgBox("Are you ready to Import WU Confirmed Amounts ?", vbQuestion + vbYesNo, "Import WU Confirmed Amounts") = vbYes Then
    Do
        WUFile = GFileName(gstFolderWesternUnion, "Please choose WU File to Import: ")
        If WUFile = "" Then
            If MsgBox("No file has been selected" & Chr(10) _
                & "[OK]     to continue and select a file." & Chr(10) _
                & "[Cancel] to Exit." & Chr(10) & Chr(10) _
                & "Please make a selection.", vbInformation + vbOKCancel, "Import WU Confirmed Amounts") = vbCancel Then
                Exit Sub
            End If
        End If
    Loop Until WUFile <> ""
    Set WS = Sheets("WU-Staging-FBME")
    'Set WSWUBalance = Sheets("WU-Balance-New")
    Set WB = Workbooks.Open(WUFile)
    Set WSWU = ActiveSheet
    
    MaxRowWU = WSWU.Range("B:B").End(xlDown).Row
    'MaxRowWUBalance = WSWUBalance.Rows(WSWUBalance.Rows.Count).End(xlUp).Row + 1

   For I = 2 To MaxRowWU
        ' WallyCode - Changed WSWU.Cells(I, "C") to WSWU.Cells(I, "D")
        '       Checking MTCN# vs Date column
        If WSWU.Cells(I, "D") <> "" Then
            ' WallyCode - Changed WSWU.Cells(I, "C") to WSWU.Cells(I, "D")
            '    Filter the MTCN# column vs the Date column.
            WS.UsedRange.AutoFilter 4, WSWU.Cells(I, "D")  ' <----- WAS "C" now "D"
            'WS.UsedRange.AutoFilter 3, Criteria1:=">=" & WSWU.Cells(I, "C"), Operator:=xlAnd, Criteria2:="<=" & WSWU.Cells(I, "C")
            'WS.UsedRange.AutoFilter 2, WSWU.Cells(I, "B")
            Set Rng = WS.UsedRange.SpecialCells(xlCellTypeVisible)
            For Each Row In Rng.EntireRow
                If Not Row.Row = 1 Then
                    'If WSWU.Cells(I, "A") = WS.Cells(Row.Row, "A") And WSWU.Cells(I, "E") = WS.Cells(Row.Row, "E") And WSWU.Cells(I, "F") = WS.Cells(Row.Row, "F") And WS.Cells(Row.Row, "H").Value = "" Then
                    'If WSWU.Cells(I, "H") = WS.Cells(Row.Row, "M") And WSWU.Cells(I, "I") = WS.Cells(Row.Row, "P") Then
                        WS.Cells(Row.Row, "H").Value = WSWU.Cells(I, "H").Value
                        WS.Cells(Row.Row, "L").Value = WSWU.Cells(I, "L").Value
                        WS.Range("H" & Row.Row).Font.ColorIndex = 5
                        TConfirmed = TConfirmed + WSWU.Cells(I, "H").Value
                        J = J + 1
                        Exit For
                    'End If
                End If
            Next Row
        End If
    Next I
    
WS.ShowAllData
WS.AutoFilterMode = False
MsgBox ("Confirmed Amounts Updated successfully for " & J & " records totalling " & TConfirmed)


'Close and Exit
WB.Close savechanges:=False
Set WB = Nothing
Set WSWU = Nothing
Set WS = Nothing

End If
End Sub
                                            
                                            
Sub SumUpCompletedBatches()
Dim WS As Worksheet
Dim MaxRow As Long, MinRow As Long, I As Long, J As Long
Dim BegBatchRow As Long, EndBatchRow As Long
Dim LastFormula As String
Dim BatchComplete As Boolean
Dim BatchValue As String

Set WS = ActiveSheet
MinRow = 2
MaxRow = WS.UsedRange.Rows.Count

'---> Find the Beginning of the first Batch
LastFormula = WS.Range("I" & MinRow).Formula

For I = MinRow To MaxRow
    If WS.Range("M" & I) <> "" And WS.Range("M" & I) <> "Commission Fee:" And WS.Range("M" & I) <> "Pickup minus fee:" And WS.Range("M" & I) <> "WU wire sent:" Then
        '---> Look for End Batch diffrent value in Col M of BatchValue
        BegBatchRow = I
        J = BegBatchRow
        BatchValue = WS.Cells(J, "M")
        Do While J <= MaxRow And WS.Range("M" & J) = BatchValue
            J = J + 1
        Loop
        EndBatchRow = J - 1
        
        '---> Locate if Batch Complete or Not
        BatchComplete = True
        For J = BegBatchRow To EndBatchRow
            If WS.Range("H" & J) = "" And WS.Range("M" & J) <> "" Then
                BatchComplete = False
                Exit For
            End If
        Next J
        
        If BatchComplete Then
            '---> Only Insert the Formulas if Not Existant Formula: =SUM(H1947:H1951)
            If WS.Range("I" & BegBatchRow).Formula = "" Then
                WS.Range("I" & BegBatchRow).Formula = "=SUM(H" & BegBatchRow & ":H" & EndBatchRow & ")"
            End If
        End If
        
        '---> In Case Next Line is blank then Extend End Batch by 1 line to trap the new beginning batch
        Do While WS.Range("M" & EndBatchRow + 1) = "" And EndBatchRow < MaxRow + 1
            EndBatchRow = EndBatchRow + 1
        Loop
        MinRow = EndBatchRow
        BegBatchRow = MinRow
        EndBatchRow = 0
        I = MinRow
    End If
    
Next I

MsgBox ("Sum of Complete Batches successfully ended.")
End Sub
                                            
                                            







Function GetEURRates() As Double
Dim WSCur As Worksheet, WS As Worksheet
Dim Cel As Range
Dim FoundIT As Boolean

Application.ScreenUpdating = False
FoundIT = False
For Each WS In ActiveWorkbook.Worksheets
    If WS.Name = "Currency Rates" Then
        FoundIT = True
        Exit For
    End If
Next WS
If Not FoundIT Then
    ActiveWorkbook.Worksheets.Add After:=ActiveWorkbook.Worksheets(Worksheets.Count)
    Set WSCur = ActiveSheet
    WSCur.Name = "Currency Rates"
Else
    Set WSCur = Sheets("Currency Rates")
End If

Sheets("WU-Staging-FBME").Activate
Set Cel = WSCur.UsedRange.Find(Format(DateValue(Now), "Mmm dd, yyyy,"), LookIn:=xlValues, lookat:=xlPart)
If Not Cel Is Nothing And WSCur.UsedRange.Rows.Count > 1 Then

Else
    WSCur.UsedRange.Delete
    
    With WSCur.QueryTables.Add(Connection:= _
        "URL;http://www.oanda.com/currency/real-time-rates", Destination:=WSCur.Range("A1") _
        )
        .Name = "real-time-rates"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingAll
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    
End If
Set Cel = WSCur.UsedRange.Find("EUR/USD", LookIn:=xlValues, lookat:=xlWhole)
If Not Cel Is Nothing Then
    GetEURRates = Cel.Offset(, 1).Value
End If

Application.ScreenUpdating = True

End Function

Function GetEURRatesNew() As Double
Dim WSCur As Worksheet, WS As Worksheet
Dim Cel As Range
Dim FoundIT As Boolean

Application.ScreenUpdating = False
FoundIT = False
For Each WS In ActiveWorkbook.Worksheets
    If WS.Name = "Currency Rates" Then
        FoundIT = True
        Exit For
    End If
Next WS
If Not FoundIT Then
    ActiveWorkbook.Worksheets.Add After:=ActiveWorkbook.Worksheets(Worksheets.Count)
    Set WSCur = ActiveSheet
    WSCur.Name = "Currency Rates"
Else
    Set WSCur = Sheets("Currency Rates")
End If

'Sheets(sht).Activate
Set Cel = WSCur.UsedRange.Find(Format(DateValue(Now), "Mmm dd, yyyy,"), LookIn:=xlValues, lookat:=xlPart)
If Not Cel Is Nothing And WSCur.UsedRange.Rows.Count > 1 Then

Else
    WSCur.UsedRange.Delete
    
    With WSCur.QueryTables.Add(Connection:= _
        "URL;http://www.xe.com", Destination:=WSCur.Range("A1") _
        )
        .Name = "xe.com"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingAll
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    
End If
Set Cel = WSCur.UsedRange.Find("EUR", LookIn:=xlValues, lookat:=xlWhole)
If Not Cel Is Nothing Then
    GetEURRatesNew = Cel.Offset(2, 0).Value
End If

Application.ScreenUpdating = True

End Function

                                            
Sub UpdateWUBalanceNew()
Dim WS As Worksheet
Dim WSWUBalance As Worksheet

Dim I As Long, J As Long
Dim MaxRow As Long, MaxRowWUBalance As Long
Dim Rng As Range
Dim Tmp

'Update WU-Balance-New
Set WS = Sheets("WU-Staging-FBME")
Set WSWUBalance = Sheets("WU-Balance-New")


MaxRow = WS.Rows(WS.Rows.Count).End(xlUp).Row + 1
MaxRowWUBalance = WSWUBalance.Rows(WSWUBalance.Rows.Count).End(xlUp).Row + 1
WSWUBalance.Range("2:" & MaxRowWUBalance).EntireRow.Delete
MaxRowWUBalance = WSWUBalance.Rows(WSWUBalance.Rows.Count).End(xlUp).Row + 1

'>> 1 >> Filter WU-Staging-FBME for dates > Oct 24, 2011
'Old way of Filtering Prior to 25/11/2011
'WS.UsedRange.AutoFilter Field:=10, Criteria1:=">=" & DateSerial(Year(StartDate), Month(StartDate), Day(StartDate))
'WS.UsedRange.AutoFilter Field:=9, Criteria1:=">=" & 0

'New way of Filtering All data
'WS.UsedRange.AutoFilter Field:=3, Criteria1:=">=" & DateSerial(Year(StartDate), Month(StartDate), Day(StartDate))
WS.UsedRange.AutoFilter Field:=9, Criteria1:=">" & 0
MaxRow = WS.Rows(WS.Rows.Count).End(xlUp).Row + 1

'>> 2 >> Add Col I
For I = 2 To MaxRow
    If WS.Range(I & ":" & I).EntireRow.Hidden = False Then
                
            'Calculate Col H and I formulas skip it and keep it blank for row 2
            If MaxRowWUBalance > 2 Then
                WSWUBalance.Cells(MaxRowWUBalance, "H").Formula = "=C" & MaxRowWUBalance & "+H" & MaxRowWUBalance - 1 & "-F" & MaxRowWUBalance
                WSWUBalance.Cells(MaxRowWUBalance, "I").Formula = "=E" & MaxRowWUBalance & "+I" & MaxRowWUBalance - 1 & "-G" & MaxRowWUBalance
            Else
                WSWUBalance.Cells(MaxRowWUBalance, "H").Formula = "=C" & MaxRowWUBalance
                WSWUBalance.Cells(MaxRowWUBalance, "I").Formula = "=E" & MaxRowWUBalance
            End If
            
            WSWUBalance.Cells(MaxRowWUBalance, "A") = WS.Cells(I, "C")
            WSWUBalance.Cells(MaxRowWUBalance, "B") = WS.Cells(I, "M")
            WSWUBalance.Cells(MaxRowWUBalance, "C") = WS.Cells(I, "I")
            
            WSWUBalance.Cells(MaxRowWUBalance, "D").Formula = "=C" & MaxRowWUBalance & " * 3.75%"
            WSWUBalance.Cells(MaxRowWUBalance, "E").Formula = "=C" & MaxRowWUBalance & "-D" & MaxRowWUBalance
            
            WSWUBalance.Cells(MaxRowWUBalance, "F") = WS.Cells(I, "AC")
            '---> Formula =F14-(F14*0.0375)
            WSWUBalance.Cells(MaxRowWUBalance, "G").Formula = "=F" & MaxRowWUBalance & "-(F" & MaxRowWUBalance & "*0.0375)"
            
            MaxRowWUBalance = WSWUBalance.Rows(WSWUBalance.Rows.Count).End(xlUp).Row + 1
                
    End If
Next I

WS.ShowAllData
WS.AutoFilterMode = False
WSWUBalance.Range("C:I").NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"
WSWUBalance.Range("A:A").HorizontalAlignment = xlCenter
WSWUBalance.Range("C:I").HorizontalAlignment = xlCenter
WSWUBalance.Range("B:B").HorizontalAlignment = xlLeft
WSWUBalance.Columns(2).AutoFit
MsgBox ("Balance Amounts Updated successfully.")

End Sub
                                            


                                            

Function GetValue(Item As Variant) As Double
Dim Tmp As Variant
Dim J As Long

GetValue = 0
If IsNumeric(Item) Then
    GetValue = Item
Else
    Tmp = Split(Item, " ")
    For J = 0 To UBound(Tmp)
        If IsNumeric(Tmp(J)) Then
            GetValue = Tmp(J)
            Exit For
        End If
    Next J
End If

End Function

Sub UpdateWUBalanceOld()
Dim WS As Worksheet
Dim WSWU As Worksheet
Dim WSWUBalance As Worksheet
Dim WB As Workbook
Dim I As Long, J As Long
Dim MaxRowWU As Long, MaxRowWUBalance As Long
Dim Rng As Range
Dim TConfirmed As Double, TColG As Double, TColH As Double
Dim WUFile As String, WUDate As String
Dim C

'Update WU-Balance-New
Set WS = Sheets("WU-Staging-FBME")
Set WSWUBalance = Sheets("WU-Balance-New")
Set WB = Workbooks.Open(WUFile)
Set WSWU = ActiveSheet

MaxRowWU = WSWU.Rows(WSWU.Rows.Count).End(xlUp).Row
MaxRowWUBalance = WSWUBalance.Rows(WSWUBalance.Rows.Count).End(xlUp).Row + 1
    
'>> 1 >> Sort WU on Col P
WSWU.Range("A3:P" & MaxRowWU).Sort Key1:=WSWU.Columns("P"), order1:=xlAscending, Header:=xlGuess
TColG = 0
TColH = 0
WUDate = WSWU.Cells(3, "P")

'>> 2 >> Add Col G and Col H for each WUDate
For I = 3 To MaxRowWU
    If WSWU.Cells(I, "P") <> "" Then
        If WSWU.Cells(I, "P") = WUDate Then
            TColG = TColG + WSWU.Cells(I, "G")
            TColH = TColH + WSWU.Cells(I, "H")
        Else
            'Lookfor WUDate in sheet 'WU-Balance-New
            Set C = WSWUBalance.UsedRange.Find(WUDate, LookIn:=xlValues, lookat:=xlWhole)
            If Not C Is Nothing Then
                'WUDate already there
                WSWUBalance.Cells(C.Row, "C") = WSWUBalance.Cells(C.Row, "C") + TColG
                WSWUBalance.Cells(C.Row, "D") = WSWUBalance.Cells(C.Row, "D") + TColH
            Else
                'WUDate not there
                Set C = WS.UsedRange.Find(WUDate, LookIn:=xlValues, lookat:=xlWhole)
                If Not C Is Nothing Then
                    WSWUBalance.Cells(MaxRowWUBalance, "A") = C.Offset(, -6)
                Else
                    WSWUBalance.Cells(MaxRowWUBalance, "A") = DateValue(Now)
                End If
                    
                WSWUBalance.Cells(MaxRowWUBalance, "B") = WUDate
                WSWUBalance.Cells(MaxRowWUBalance, "C") = TColG
                WSWUBalance.Cells(MaxRowWUBalance, "D") = TColH
                WSWUBalance.Cells(MaxRowWUBalance, "G").Formula = "=D" & MaxRowWUBalance & "*0.5%"
                WSWUBalance.Cells(MaxRowWUBalance, "I").Formula = "=E" & MaxRowWUBalance & "+G" & MaxRowWUBalance & "-D" & MaxRowWUBalance
                
                'Calculate Cumulative Totals
                If MaxRowWUBalance = 2 Then
                    WSWUBalance.Cells(MaxRowWUBalance, "H").Formula = "=G" & MaxRowWUBalance
                    WSWUBalance.Cells(MaxRowWUBalance, "J").Formula = "=I" & MaxRowWUBalance
                Else
                    WSWUBalance.Cells(MaxRowWUBalance, "H").Formula = "=G" & MaxRowWUBalance & "+H" & MaxRowWUBalance - 1
                    WSWUBalance.Cells(MaxRowWUBalance, "J").Formula = "=I" & MaxRowWUBalance & "+J" & MaxRowWUBalance - 1
                End If
            End If
            'Re-Calculate new maxrow and new WUDate
            MaxRowWUBalance = WSWUBalance.Rows(WSWUBalance.Rows.Count).End(xlUp).Row + 1
            WUDate = WSWU.Cells(I, "P")
            TColG = 0
            TColH = 0
        End If
        
    End If
Next I

MsgBox ("Balance Amounts Updated successfully.")

End Sub


Sub WMFileCreate(WS As Worksheet)
Dim WSS As Worksheet
Dim NewWS As Worksheet
Dim MaxRow As Long, WUwiresentRow As Long, I As Long, J As Long, K As Long
Dim NewWb As Workbook
Dim NewWorkB As String
Dim X

If gstFolderWesternUnion = "" Then
    MsgBox ("You need to select a destination folder to store the western Union files created. Please go to Sheet 'Main' and select a folder before proceeding further.")
    Exit Sub
Else
    If MsgBox("This process will create a new workbook with all records in sheet 'WU-Staging-FBME' that have NO date in Col J." & Chr(10) & Chr(10) _
        & "Are you ready to start this process ?", vbQuestion + vbYesNo, "Step 2 - Generate WU File ") = vbYes Then
        
        '---> Filter by WU Wire sent in Col M
        WS.UsedRange.AutoFilter Field:=13, Criteria1:="=" & "WU wire sent:"
        WUwiresentRow = WS.Range("M1").End(xlDown).Row
        WS.ShowAllData
        WS.AutoFilterMode = False
        
        J = 1
        'First Criteria Col J = ''
        WS.UsedRange.AutoFilter Field:=10, Criteria1:="=" & ""
        'Second Criteria Col D <>''
        'WS.UsedRange.AutoFilter Field:=4, Criteria1:="=*"
        WS.UsedRange.AutoFilter Field:=4, Criteria1:="<>" & "", Operator:=xlOr, Criteria2:="=" & "*"
        MaxRow = WS.UsedRange.Rows.Count
        
        Set NewWb = Workbooks.Add
        Set NewWS = NewWb.Sheets("Sheet1")
        NewWS.Name = "WU" & Format(Now, "mm-dd-yyyy")
        
        'Visa - WUSept9-11.xls'
        NewWb.SaveAs Filename:=gstFolderWesternUnion & "WU" & Format(Now, "Mmmd-yy") & ".xls", FileFormat:=xlExcel8
        NewWorkB = NewWb.FullName
    
        For I = 1 To MaxRow
            '---> Insert Green row WU Wire sent at row 2
            If J = 2 Then
                WS.Range("A" & WUwiresentRow & ":P" & WUwiresentRow).Copy
                NewWS.Range("A" & J).PasteSpecial Paste:=xlPasteFormats
                NewWS.Range("A" & J).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                J = J + 1
            End If
            
            If WS.Range(I & ":" & I).EntireRow.Hidden = False Then
                WS.Range("A" & I & ":P" & I).Copy NewWS.Cells(J, 1)
                If NewWS.Range("D" & J) <> "" And NewWS.Range("D" & J) <> " " And I <> 1 Then
                    NewWS.Range("P" & J) = "WU" & Format(Now, "Mmmdd-yy")
                End If
                J = J + 1
            End If
        Next I
        NewWS.Range("Q:Z").EntireColumn.Delete
        
        '---> Add 4 Green Rows with Formulas in NewWS
        NewWS.Range("A" & J & ":P" & J + 3).Interior.ColorIndex = 4
        For K = J To J + 3
            NewWS.Range("A" & K & ":P" & K).Borders(xlEdgeBottom).LineStyle = xlContinuous
        Next K
        NewWS.Range("F" & J) = "Totals:"
        NewWS.Range("G" & J).Formula = "=SUM(G2:G" & J - 1 & ")"
        NewWS.Range("H" & J).Formula = "=SUM(H2:H" & J - 1 & ")"
        NewWS.Range("M" & J) = "Commission Fee:"
        NewWS.Range("O" & J).Formula = "=H" & J & "*0.0375"
        
        NewWS.Range("M" & J + 1) = "Pickup minus fee:"
        NewWS.Range("O" & J + 1).Formula = "=H" & J & "-O" & J
        
        NewWS.Range("M" & J + 2) = "Previous Balance:"
        NewWS.Range("O" & J + 2).Formula = "=O2"
        
        NewWS.Range("M" & J + 3) = "WU wire sent:"
        NewWS.Range("N" & J + 3) = 0
        NewWS.Range("O" & J + 3).Formula = "=O" & J + 1 & "+O" & J + 2 & "-N" & J + 3
        
        '---> Add 4 Green Rows with Formulas in WS
        WS.Range("A" & MaxRow + 1 & ":AO" & MaxRow + 4).Interior.ColorIndex = 4
        For K = MaxRow + 1 To MaxRow + 4
            WS.Range("A" & K & ":AO" & K).Borders(xlEdgeBottom).LineStyle = xlContinuous
        Next K
        WS.Range("F" & MaxRow + 1) = "Totals:"
        WS.Range("G" & MaxRow + 1).Formula = "=SUM(G" & WUwiresentRow + 1 & ":G" & MaxRow & ")"
        WS.Range("H" & MaxRow + 1).Formula = "=SUM(H" & WUwiresentRow + 1 & ":H" & MaxRow & ")"
        WS.Range("M" & MaxRow + 1) = "Commission Fee:"
        WS.Range("O" & MaxRow + 1).Formula = "=H" & MaxRow + 1 & "*0.0375"
        
        WS.Range("M" & MaxRow + 2) = "Pickup minus fee:"
        WS.Range("O" & MaxRow + 2).Formula = "=H" & MaxRow + 1 & "-O" & MaxRow + 1
        
        WS.Range("M" & MaxRow + 3) = "Previous Balance:"
        WS.Range("O" & MaxRow + 3).Formula = "=O" & WUwiresentRow
        
        WS.Range("M" & MaxRow + 4) = "WU wire sent:"
        WS.Range("N" & MaxRow + 4) = 0
        WS.Range("O" & MaxRow + 4).Formula = "=O" & MaxRow + 2 & "+O" & MaxRow + 3 & "-N" & MaxRow + 4
           
        With NewWS.Columns("A:P")
           .EntireColumn.AutoFit
           .HorizontalAlignment = xlLeft
        End With
           
        With NewWS.Columns("N:O")
           .EntireColumn.AutoFit
           .HorizontalAlignment = xlRight
        End With
        
        NewWS.Range("G" & J & ":H" & J).NumberFormat = "$#,##0.00;[Red]($#,##0.00)"
        NewWS.Range("N" & J & ":O" & J + 3).NumberFormat = "$#,##0.00;[Red]($#,##0.00)"
        
        With WS.Columns("N:O")
           .EntireColumn.AutoFit
           .HorizontalAlignment = xlRight
        End With
        
        WS.Range("G" & MaxRow + 1 & ":H" & MaxRow + 1).NumberFormat = "$#,##0.00;[Red]($#,##0.00)"
        WS.Range("N" & MaxRow + 1 & ":O" & MaxRow + 4).NumberFormat = "$#,##0.00;[Red]($#,##0.00)"


        Application.DisplayAlerts = False
        
        For Each WSS In NewWb.Worksheets
            If WSS.Name <> NewWS.Name Then WSS.Delete
        Next WSS
        
        
        NewWb.Save
        
        Application.DisplayAlerts = True
        MaxRow = NewWS.UsedRange.Rows.Count
        
        If MaxRow > 2 Then
            gstGenerateWUName = NewWb.FullName
            gstGenerateWUEmail = ""
            X = MsgBox("Workbook: '" & NewWorkB & "' has been created successfully. Please check workbook to ensure all data is accurate. After all modifications done please ensure file is saved to proceed to Next Step 3 - [ Generate Email & Update 'WU-Staging-FBME']", vbInformation, "Step 2 - Generate WU File")
        Else
            Application.DisplayAlerts = False
            NewWb.Close savechanges:=False
            Kill NewWorkB
            Application.DisplayAlerts = True
            gstGenerateWUName = ""
            gstGenerateWUEmail = ""
            MsgBox ("No Records were found ! nothing to Export.")
        End If
        WS.ShowAllData
        WS.AutoFilterMode = False
    End If
End If
End Sub
                                            

Sub SendEmail(fName As String)
Dim WB As Workbook
Dim WS As Worksheet


Dim SendTo As String
Dim OutlookApp As Object
Dim MItem As Object
Dim subject_ As String
Dim attach_ As String


Application.DisplayAlerts = False

'Create Outlook
Set OutlookApp = CreateObject("Outlook.Application")

'Fill in Subject Details'
subject_ = "Western Union Pickup Request" & Format(Now, "Mmmd-yy")
attach_ = fName
SendTo = "otto.weber@offshoreagle.com;mintakutya@gmail.com"

'Create the Email
Set MItem = OutlookApp.CreateItem(0)
With MItem
  .To = SendTo
  .Subject = subject_
  .Attachments.Add (attach_)
  .Body = "Hello Joseph," & Chr(10) & Chr(10) _
    & "Attached is our pick up request for today." & Chr(10) _
    & "Thank you." & Chr(10) & Chr(10) _
    & "Michael" & Chr(10) _
    & "Sovereign Gold Card Support" & Chr(10) _
    & "www.sovereigngoldcard.com"

  'Send the Email
  .Display
End With

'Clear Resources
Set MItem = Nothing
Set OutlookApp = Nothing

Application.DisplayAlerts = True
End Sub

Sub SendVisaEmail(fName As String)
Dim WB As Workbook
Dim WS As Worksheet


Dim SendTo As String
Dim OutlookApp As Object
Dim MItem As Object
Dim subject_ As String
Dim attach_ As String


Application.DisplayAlerts = False

'Create Outlook
Set OutlookApp = CreateObject("Outlook.Application")

'Fill in Subject Details'
subject_ = Right(fName, Len(fName) - InStrRev(fName, "\", Len(fName)))
attach_ = fName
SendTo = "oxana.bondarenko@fbmecs.com; emily.pain@fbmecs.com;"

'Create the Email
Set MItem = OutlookApp.CreateItem(0)
With MItem
  .To = SendTo
  .Subject = subject_
  .Attachments.Add (attach_)
  .Body = "Dear Oxana and Emily," & Chr(10) & Chr(10) _
    & "Attached is our loading request for the day." & Chr(10) _
    & "As always, please send me our account balance," & Chr(10) _
    & "when convenient, at the end of your day." & Chr(10) & Chr(10) _
    & "Could you also let me know the latest deposit" & Chr(10) _
    & "with our account balance?" & Chr(10) & Chr(10) _
    & "Thank you." & Chr(10) & Chr(10) _
    & "Michael" & Chr(10) _
    

  'Send the Email
  .Display
End With

gstGenerateVisaEmail = fName

'Clear Resources
Set MItem = Nothing
Set OutlookApp = Nothing

Application.DisplayAlerts = True
End Sub


Function GetNewFolder(ByVal fFolder As String, Title As String)

fFolder = GFolderName(Title)

If fFolder <> "" And Dir(fFolder, vbDirectory) <> "" Then
    GetNewFolder = fFolder
Else
    MsgBox ("No Folder has been selected or the Folder does not exist, therefore data cannot be Exported" _
        & " until valid Folder has been selected." & Chr(10) & Chr(10) _
        & "Please press on the command bar to choose a Folder.")
    GetNewFolder = "Browse"

    With Application
        .DisplayAlerts = True
        .EnableEvents = True
    End With
    
    Exit Function
End If
End Function
                                            

Function GFolderName(Fol As String) As String
Dim vrtSelectedItem

With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Application.ActiveWorkbook.Path
    .Title = "Please choose Folder location for: " & Fol
    .InitialView = msoFileDialogViewDetails
    .InitialFileName = ""
    .Show
    
    
    
    For Each vrtSelectedItem In .SelectedItems
    GFolderName = vrtSelectedItem & "\"
    Next vrtSelectedItem
End With

Set vrtSelectedItem = Nothing

End Function


Function GFileName(Fol As String, Title As String) As String
Dim vrtSelectedItem

With Application.FileDialog(msoFileDialogFilePicker)
    .InitialFileName = Fol
    .Title = Title & Fol
    .Filters.Add "Excel ", "*.xls*", 1
    .InitialView = msoFileDialogViewDetails
    .Show
    
    
    For Each vrtSelectedItem In .SelectedItems
    GFileName = vrtSelectedItem
    Next vrtSelectedItem
End With

Set vrtSelectedItem = Nothing

End Function



Sub FillCombo(Combo As ComboBox)
On Error Resume Next

Combo.Clear
'Folders Level1
Set myolApp = CreateObject("Outlook.Application")

With myolApp.GetNamespace("MAPI").Folders
    For I = 1 To .Count
    If .Count > 0 Then
        'If .Item(I).AddressBookName <> "" Then Combo.AddItem .Item(I).FolderPath
        Combo.AddItem .Item(I).FolderPath
        
        'Folders Level2
        With myolApp.GetNamespace("MAPI").Folders.Item(I).Folders
            For J = 1 To .Count
            If .Count > 0 Then
                'If .Item(J).AddressBookName <> "" Then Combo.AddItem .Item(J).FolderPath
                Combo.AddItem .Item(J).FolderPath
                
                'Folders Level3
                With myolApp.GetNamespace("MAPI").Folders.Item(I).Folders.Item(J).Folders
                    For K = 1 To .Count
                    If .Count > 0 Then
                        'If .Item(K).AddressBookName <> "" Then Combo.AddItem .Item(K).FolderPath
                        Combo.AddItem .Item(K).FolderPath
                    End If
                    Next K
                End With
            End If
            Next J
        End With
    End If
    Next I
End With
wsMain.Range("L" & CRow) = "Fill " & Combo & " Successful"
CRow = CRow + 1

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

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


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

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

Dim VItem As Outlook.MailItem

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

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

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

Application.EnableEvents = False

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

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

Application.EnableEvents = True

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

End Sub




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

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

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


Sub LocateEmailsToTabsNew()
On Error GoTo Errhandler1

Dim FoundIT As Boolean
Dim Body As String
Dim MaxRow As Long, EmailMoved As Long, EmailNotMoved As Long, TotItems As Long
Dim I As Long, J As Long
Dim FMonitor, FTransfer

Set objOutlook = CreateObject("Outlook.application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
'Set objFolder = objNameSpace.Folders(gstFolderToMonitor)

FMonitor = Split(Mid(gstFolderToMonitor, 2), "\")
If Not SetMonitorFolder(FMonitor) Then
    MsgBox ("Monitor Folder is Invalid. Please check it and try running this procedure again")
    Exit Sub
End If
wsMain.Range("L" & CRow) = "Locate Emails - FMonitor: " & objFolderToMonitor
CRow = CRow + 1

FTransfer = Split(Mid(gstFolderToTransfer, 2), "\")
If Not SetTransferFolder(FTransfer) Then
    MsgBox ("Transfer Folder is Invalid. Please check it and try running this procedure again")
    Exit Sub
End If
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
Set VItem = VisaItems.Find("[Subject] = 'Payment Received'")
TotItems = VisaItems.Count
I = 1

Do
'For Each VItem In VisaItems
    wsMain.Range("L" & CRow) = "Locate Emails - VisaItems: " & 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
    'MaxRow = wsVisa.UsedRange.Rows.count
    'MaxRow = wsVisa.Range("B1048576").End(xlUp).Row
    'Application.EnableEvents = False
    st = ImportData5New(Body, Etime, MaxRow + 1)
    'Application.EnableEvents = True
    If st <> "" Then
        MsgBox ("Email From: [" & st & "] Not Imported")
        EmailNotMoved = EmailNotMoved + 1
        'If VItem.Categories <> "Processed" Then VItem.Categories = "Not Processed"
        'VItem.Save
        wsMain.Range("L" & CRow) = "Locate Emails - Not Imported: <" & st & "> "
        CRow = CRow + 2

    Else
        'objMail.Move objFolderToTransfer
        'VItem.Move objFolderToTransfer
        EmailMoved = EmailMoved + 1
        'VItem.Categories = "Processed"
        'VItem.Save
        wsMain.Range("L" & CRow) = "Locate Emails - Imported and Not Moved: <" & VItem.SenderEmailAddress & "> "
        CRow = CRow + 2

    End If
    I = I + 1
    Set VItem = VisaItems.FindNext
Loop Until I = TotItems + 1

MsgBox ("Total Emails processed from '" & objFolderToMonitor & "' " & TotItems & Chr(10) _
    & "Total Emails Imported and Not Moved: " & EmailMoved & Chr(10) _
    & "Total Emails Not Imported: " & EmailNotMoved & " and kept in '" & objFolderToMonitor & "'" _
    & "Imported Emails were kept in : '" & objFolderToMonitor & "'")
wsMain.Range("L" & CRow) = ("Locate Emails - Total Emails processed from '" & objFolderToMonitor & "' " & TotItems _
    & "Total Emails Imported and Not Moved: " & EmailMoved _
    & "Total Emails Not Imported: " & EmailNotMoved & " and kept in '" & objFolderToMonitor & "'" _
    & "Imported Emails were kept in: '" & objFolderToMonitor & "'")
CRow = CRow + 1

Exit Sub

Errhandler1:
MsgBox (Error(Err))
wsMain.Range("L" & CRow) = "Locate Emails - Error: <" & Error(Err) & "> Item " & VItem
CRow = CRow + 1
Resume Next

End Sub



Sub LocateEmails()
On Error GoTo Errhandler1

Dim FoundIT As Boolean
Dim Body As String
Dim MaxRow As Long, EmailMoved As Long, EmailNotMoved As Long, TotItems As Long
Dim I As Long, J As Long, K As Long, L As Long
Dim FMonitor, FTransfer
Dim tmpBody, tmpTransferLine
Dim TransAmount As Double

Set objOutlook = CreateObject("Outlook.application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
'Set objFolder = objNameSpace.Folders(gstFolderToMonitor)

FMonitor = Split(Mid(gstFolderToMonitor, 2), "\")
If Not SetMonitorFolder(FMonitor) Then
    MsgBox ("Monitor Folder is Invalid. Please check it and try running this procedure again")
    Exit Sub
End If
wsMain.Range("L" & CRow) = "Locate Emails - FMonitor: " & objFolderToMonitor
CRow = CRow + 1

FTransfer = Split(Mid(gstFolderToTransfer, 2), "\")
If Not SetTransferFolder(FTransfer) Then
    MsgBox ("Transfer Folder is Invalid. Please check it and try running this procedure again")
    Exit Sub
End If
wsMain.Range("L" & CRow) = "Locate Emails - FTransfer: " & objFolderToTransfer
CRow = CRow + 1

Dim VItem As Outlook.MailItem

Set VisaItems = objFolderToMonitor.Items.Restrict("[Subject] = 'Payment Received' or ([Subject] >= 'Bank Transfer # ' and [Subject] <= 'Bank Transfer #z')")
VisaItems.Sort "receivedtime", False
Set VItem = VisaItems.Find("[Subject] = 'Payment Received' or ([Subject] >= 'Bank Transfer # ' and [Subject] <= 'Bank Transfer #z')")
TotItems = VisaItems.Count
I = 1

Do
'For Each VItem In VisaItems
    wsMain.Range("L" & CRow) = "Locate Emails - VisaItems: " & 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
    MaxRow = WSVisa.UsedRange.Rows.Count
    
    '---> Depending on Type of Mail route Import
    If InStr(1, objMail.Subject, "Bank Transfer #") <> 0 Then
        '---> Process Bank Transfer Emails
        tmpBody = Split(objMail.Body, Chr(10))
        st = "Bank Transfer"
        For K = 0 To UBound(tmpBody)
            If InStr(1, tmpBody(K), "Bank Transfer #") <> 0 And InStr(1, tmpBody(K), "for EUR") <> 0 Then
                tmpTransferLine = Split(Right(tmpBody(K), Len(tmpBody(K)) - InStr(1, tmpBody(K), "for EUR") + 1), " ")
                For L = 0 To UBound(tmpTransferLine)
                    If IsNumeric(tmpTransferLine(L)) Then
                        TransAmount = tmpTransferLine(L)
                        'MaxRow = Sheets("FBME Balance").Range("B1048576").End(xlUp).Row + 1
                        MaxRow = Sheets("FBME Balance").UsedRange.Rows.Count + 1
                        Sheets("FBME Balance").Range("C" & MaxRow) = TransAmount
                        Sheets("FBME Balance").Range("A" & MaxRow) = Etime
                        Exit For
                    End If
                Next L
                If st = "Bank Transfer" Then
                    st = ""
                    Exit For
                End If
            End If
        Next K
    Else
        st = ImportData(Body, Etime, MaxRow + 1)
    End If
    
    If st <> "" Then
        MsgBox ("Email From: [" & st & "] not imported")
        EmailNotMoved = EmailNotMoved + 1
        If VItem.Categories <> "Green Category" Then VItem.Categories = "Red Category"
        VItem.Save
        wsMain.Range("L" & CRow) = "Locate Emails - Not Imported: <" & st & "> "
        CRow = CRow + 2

    Else
        'objMail.Move objFolderToTransfer
        'VItem.Move objFolderToTransfer
        EmailMoved = EmailMoved + 1
        VItem.Categories = "Green Category"
        VItem.Save
        wsMain.Range("L" & CRow) = "Locate Emails - Imported but not Moved: <" & st & "> " & objFolderToMonitor.Items.Item(EmailMoved)
        CRow = CRow + 2

    End If
    I = I + 1
    Set VItem = VisaItems.FindNext
Loop Until I = TotItems + 1

MsgBox ("Total Emails processed from '" & objFolderToMonitor & "' " & TotItems & Chr(10) _
    & "Total Emails Imported: " & EmailMoved & Chr(10) _
    & "Total Emails Not Imported: " & EmailNotMoved & " and kept in '" & objFolderToMonitor & "'" _
    & "All Emails were kept in their original location: '" & objFolderToMonitor & "'")
wsMain.Range("L" & CRow) = ("Locate Emails - Total Emails processed from '" & objFolderToMonitor & "' " & TotItems _
    & "Total Emails Imported: " & EmailMoved _
    & "Total Emails Not Imported: " & EmailNotMoved & " and kept in '" & objFolderToMonitor & "'" _
    & "All Emails were kept in their original location: '" & objFolderToMonitor & "'")
CRow = CRow + 1

Exit Sub

Errhandler1:
MsgBox (Error(Err))
wsMain.Range("L" & CRow) = "Locate Emails - Error: <" & Error(Err) & "> Item " & VItem
CRow = CRow + 1
Resume Next

End Sub
                                            


Sub GetEmails()
Dim FoundIT As Boolean
Dim Body As String
Dim MaxRow As Long
Dim I, J As Long

'Application.DisplayAlerts = False
'Application.ScreenUpdating = False

Set objOutlook = CreateObject("Outlook.application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set objFolders = objNameSpace.Folders
'Set objFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
For Each objFolder In objFolders
    If objFolder = "gowflow" Then
        FoundIT = True
        Exit For
    End If
Next objFolder

cnt = objFolder.Folders.Count

For J = 1 To cnt
    If objFolder.Folders(J) = "Inbox" Then
        Set InboxFolder = objFolder.Folders(J)
        cntsub = objFolder.Folders(J).Folders.Count
        For I = 1 To cntsub
            If objFolder.Folders(J).Folders(I) = "InboxImport" Then
                Set objFolder = objFolder.Folders(J).Folders(I)
                FoundIT = True
                Exit For
            End If
        Next I
        Exit For
    End If
Next J

Set VisaItems = objFolder.Items.Restrict("[Subject] = 'Payment Received'")
'cnt = VisaItems.Count

    For I = VisaItems.Count To 1 Step -1
        Set objMail = VisaItems(I)
        ' use Instr here to check subject or body
        'MsgBox objMail.Subject
        Body = objMail.Body
        Etime = objMail.ReceivedTime
        MaxRow = WSVisa.UsedRange.Rows.Count
        'MaxRow = ActiveSheet.Range("B1048576").End(xlUp).Row
        st = ImportData(Body, Etime, MaxRow + 1)
        If st <> "" Then
            MsgBox ("Email From: [" & st & "] not imported")
        End If
        objMail.Move InboxFolder.Folders("EP Wires")
        'MoveEmail objMail
    Next I
End Sub






Function SetMonitorFolder(FMonitor As Variant) As Boolean
On Error GoTo Errhandler3

Select Case UBound(FMonitor)
    Case 0
    MsgBox ("There is no folder to monitor, Please select a folder first")
    SetMonitorFolder = False
    Exit Function
    
    Case 1
    Set objFolderToMonitor = objNameSpace.Folders(FMonitor(1))
    
    Case 2
    Set objFolderToMonitor = objNameSpace.Folders(FMonitor(1)).Folders(FMonitor(2))
    
    Case 3
    Set objFolderToMonitor = objNameSpace.Folders(FMonitor(1)).Folders(FMonitor(2)).Folders(FMonitor(3))
    
    Case 4
    Set objFolderToMonitor = objNameSpace.Folders(FMonitor(1)).Folders(FMonitor(2)).Folders(FMonitor(3)).Folders(FMonitor(4))
    
    Case 5
    Set objFolderToMonitor = objNameSpace.Folders(FMonitor(1)).Folders(FMonitor(2)).Folders(FMonitor(3)).Folders(FMonitor(4)).Folders(FMonitor(5))

End Select
SetMonitorFolder = True

Exit Function

Errhandler3:
MsgBox (Error(Err))
wsMain.Range("L" & CRow) = "SetMonitorFolder - Error: <" & Error(Err) & "> Item " & UBound(FMonitor) & " Invalid Folder"
CRow = CRow + 1
SetMonitorFolder = False
Exit Function
Resume Next

End Function
Function ImportData(Body As String, ByVal RDate As Date, Row As Long) As String
On Error GoTo Errhandler2

Dim CC As String
Dim ID As String
Dim CName As String
Dim Cur As String
Dim Amt As Double
Dim Tmp As String

tmpa = Split(Body, Chr(10))

For I = 0 To UBound(tmpa)
    'Find CC and CName
    st = InStr(1, tmpa(I), "From:", vbTextCompare)
    If st <> 0 Then
        'New Way of Capturing Fields
        tmpb = Split(Mid(tmpa(I), st + 6, InStr(st, tmpa(I), Chr(13), vbBinaryCompare)), " ")
        For J = 0 To UBound(tmpb)
                If IsNumeric(tmpb(J)) And Left(tmpb(J), 1) = "4" Then
                    CC = tmpb(J)
                Else
                    If IsNumeric(tmpb(J)) And Left(tmpb(J), 3) = "100" Then
                        ID = tmpb(J)
                    Else
                        If Not IsNumeric(tmpb(J)) And Len(tmpb(J)) <> 1 And tmpb(J) <> "-" Then
                            CName = CName & tmpb(J) & " "
                        Else
                            If IsNumeric(tmpb(J)) And CC <> "" And Left(tmpb(J), 1) <> "4" Then
                                CC = CC & tmpb(J)
                            End If
                        End If
                    End If
                End If
        Next J
        CName = RTrim(CName)
        If CC = "" Then
            ImportData = Mid(tmpa(I), st + 6)
            Exit Function
        End If
        'Old Way of Capturing Fields
        'If Not IsNumeric(Mid(tmpa(I), st + 6, 1)) Or Mid(tmpa(I), st + 6, 1) <> "4" Then
        '    ImportData = Mid(tmpa(I), st + 6)
        '    Exit Function
        'Else
        '    tmpb = Split(Mid(tmpa(I), st + 6, InStr(st, tmpa(I), Chr(13), vbBinaryCompare)), " ")
        '    For J = 0 To UBound(tmpb)
        '        If IsNumeric(tmpb(J)) Then
        '            CC = CC & tmpb(J)
        '        Else
        '            Exit For
        '        End If
        '    Next J
            
        '    For K = J To UBound(tmpb)
        '        CName = CName & tmpb(K) & " "
        '    Next K
        '    CName = RTrim(CName)
        'End If
    End If
    
    'Find Curency, Amt
    st = InStr(1, tmpa(I), "Amount:", vbTextCompare)
    If st <> 0 Then
        tmpb = Split(Mid(tmpa(I), st + 8, InStr(st, tmpa(I), Chr(13), vbBinaryCompare)), " ")
        If UBound(tmpb) = 1 Then
            Cur = tmpb(0)
            Amt = tmpb(1)
        End If
    End If
Next I

'Save to Excel
With WSVisa
    .Cells(Row, "B") = RDate
    .Cells(Row, "C") = CName
    .Cells(Row, "D") = ID
    .Cells(Row, "G").NumberFormat = "@"
    .Cells(Row, "G") = CC
    
    .Cells(Row, "E") = Cur
    If Cur = "EUR" Then
        .Cells(Row, "J") = Amt
        'Get Real time Currency Rate
        .Cells(Row, "P").Value = .Cells(Row, "F").Value * GetEURRatesNew()
        .Cells(Row, "Q").Value = .Cells(Row, "M").Value * GetEURRatesNew()
    Else
        .Cells(Row, "K") = Amt
    End If
    wsMain.Range("L" & CRow) = "Import Data : <" & CName & " " & RDate
    CRow = CRow + 1
End With
ImportData = ""

Exit Function

Errhandler2:
MsgBox (Error(Err))
wsMain.Range("L" & CRow) = "Import Data - Error: <" & Error(Err) & "> Item " & CName & " " & RDate
CRow = CRow + 1

Resume Next

End Function
                                            






                                            



Function SetTransferFolder(FTransfer As Variant) As Boolean
On Error GoTo Errhandler4

Select Case UBound(FTransfer)
    Case 0
    MsgBox ("There is no folder to Transfer, Please select a folder first")
    SetTransferFolder = False
    Exit Function
    
    Case 1
    Set objFolderToTransfer = objNameSpace.Folders(FTransfer(1))
    
    Case 2
    Set objFolderToTransfer = objNameSpace.Folders(FTransfer(1)).Folders(FTransfer(2))
    
    Case 3
    Set objFolderToTransfer = objNameSpace.Folders(FTransfer(1)).Folders(FTransfer(2)).Folders(FTransfer(3))
    
    Case 4
    Set objFolderToTransfer = objNameSpace.Folders(FTransfer(1)).Folders(FTransfer(2)).Folders(FTransfer(3)).Folders(FTransfer(4))
    
    Case 5
    Set objFolderToTransfer = objNameSpace.Folders(FTransfer(1)).Folders(FTransfer(2)).Folders(FTransfer(3)).Folders(FTransfer(4)).Folders(FTransfer(5))

End Select
SetTransferFolder = True

Exit Function

Errhandler4:
MsgBox (Error(Err))
wsMain.Range("L" & CRow) = "SetTransferFolder - Error: <" & Error(Err) & "> Item " & UBound(FTransfer) & " Invalid Folder"
CRow = CRow + 1
SetTransferFolder = False
Exit Function
Resume Next

End Function



Sub WUEmailCreate(WS As Worksheet, NewWorkB As String)
Dim NewWb As Workbook
Dim NewWS As Worksheet
Dim MaxRow As Long, I As Long, J As Long


If MsgBox("Are you ready to proceed with Email Creation for file '" & NewWorkB & "' and Update sheet 'WU-Staging-FBME' with today's date in Col J ?", vbQuestion + vbYesNo, "Step 3 - Generate Email & Update 'WU-Staging-FBME'") = vbYes Then
            
    Set NewWb = Workbooks.Open(NewWorkB)
    Set NewWS = ActiveSheet
    
    J = 1
    'First Criteria Col J = ''
    WS.UsedRange.AutoFilter Field:=10, Criteria1:="=" & ""
    'Second Criteria Col D <>''
    WS.UsedRange.AutoFilter Field:=4, Criteria1:="=" & "*"
    MaxRow = WS.UsedRange.Rows.Count
        
    For I = 2 To MaxRow
        If WS.Range(I & ":" & I).EntireRow.Hidden = False Then
            If WS.Range("D" & I) <> "" And WS.Range("D" & I) <> " " Then
                WS.Range("J" & I) = DateValue(Now)
                WS.Range("P" & I) = "WU" & Format(Now, "Mmmdd-yy")
                J = J + 1
            Else
                WS.Range("J" & I) = Chr(13)
                J = J + 1
            End If
        End If
    Next I
    WS.ShowAllData
    WS.AutoFilterMode = False
    SendEmail NewWb.FullName
    gstGenerateWUEmail = NewWb.FullName
Else
    MsgBox ("Request Canceled by user, No Email created and Col J and P not updated in 'WU-Staging-FBME'")
End If
End Sub


Sub CreateMonthlyTotals()
Dim WS As Worksheet
Dim WSS As Worksheet
Dim GraphWS As Worksheet
Dim NewWS As Worksheet
Dim MaxRow As Long, I As Long, J As Long, K As Long, DateCol As Long
Dim NewWb As Workbook
Dim GraphWb As Workbook
Dim NewWorkB As String
Dim EOMonth As String, Todate As Date, SDate As Date
Dim RngE As Range
Dim cCell As Range

If gstFolderMonthlyTotalsFile = "" Then
    MsgBox ("You need to select a destination folder to store the Monthly Totals File created. Please go to Sheet 'Main' and select a folder before proceeding further.")
    Exit Sub
Else
    If MsgBox("This process will create a new workbook with Last Month's date and load in it all records in sheets:" & Chr(10) _
        & "'Wire-Staging-FBME' that bear Last Month's date. AND " & Chr(10) _
        & "'WU-Staging-FBME'   that bear Last Month's date. AND " & Chr(10) _
        & "Will save found data in Graph file 'Monthly-Totals-By-Year.xls' in its coresponding Year and Month." & Chr(10) & Chr(10) _
        & "Are you ready to start this process ?", vbQuestion + vbYesNo, "Create Monthly Totals") = vbYes Then
        
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        '---> Update Wire-Staging-FBME
        Set WS = Sheets("Wire-Staging-FBME")
        
        '---> Setup Last Month Date
        If Month(Now) = 1 Then
            SDate = DateSerial(Year(Now) - 1, 12, 1)
        Else
            SDate = DateSerial(Year(Now), Month(Now) - 1, 1)
        End If
        
        '---> Check if file already Exist then Open it else create the file from BlankMonthlyTotals and
        '     Name it to Previous Month's date
        On Error Resume Next
        Application.AutomationSecurity = msoAutomationSecurityForceDisable
        Application.EnableEvents = False
        Set NewWb = Workbooks.Open(Filename:=gstFolderMonthlyTotalsFile & Format(SDate, "Mmmm") & "-" & Format(SDate, "yyyy") & ".xls")
        Application.EnableEvents = True
        
        If Err <> 0 Then
            MsgBox ("File " & Format(SDate, "Mmmm") & "-" & Format(SDate, "yyyy") & ".xls was not found will create it from 'BlankMonthlyTotals.xls'")
            On Error GoTo 0

        
            '---> new procedure for opening the default blankMonthlyTotals set by gowflow on 3/2/2012
            On Error Resume Next
            Application.AutomationSecurity = msoAutomationSecurityForceDisable
            Application.EnableEvents = False
            Set NewWb = Workbooks.Open(Filename:=gstFolderMonthlyTotalsFile & "BlankMonthlyTotals.xls")
    
            Application.EnableEvents = True
            If Err <> 0 Then
                MsgBox ("Default blank file 'BlankMonthlyTotals.xls' was not found please create it or adjus file folder location then re-start this procedure.")
                Exit Sub
            End If
            On Error GoTo 0
        
        Else
            MsgBox ("File " & Format(SDate, "Mmmm") & "-" & Format(SDate, "yyyy") & ".xls was found and will Update necessary info.")

        End If
 
        '---> Set Activesheet
        Set NewWS = NewWb.ActiveSheet
        
        Application.EnableEvents = False
        Application.DisplayAlerts = False
        NewWb.SaveAs Filename:=gstFolderMonthlyTotalsFile & Format(SDate, "Mmmm") & "-" & Format(SDate, "yyyy") & ".xls", FileFormat:=xlExcel8
        Application.EnableEvents = True
        Application.DisplayAlerts = True
        NewWorkB = NewWb.Name
        

        '---> updated by gowflow on 7/2/2012
        'J = 3
        'K = 1
        'Date Col A
        DateCol = 1
        
        '---> Locate end month
        Todate = Application.WorksheetFunction.EOMonth(SDate, 0)
        
        '---> Filter Records where Date between SDate and ToDate
        WS.UsedRange.AutoFilter Field:=DateCol, Criteria1:=">=" & SDate, Operator:=xlAnd, Criteria2:="<=" & Todate
        
        '---> Affect to RngE the visible data
        Set RngE = WS.Range("P:P").SpecialCells(xlCellTypeVisible)
        NewWS.Range("B20") = Application.WorksheetFunction.Sum(RngE)
        
        Set RngE = WS.Range("Q:Q").SpecialCells(xlCellTypeVisible)
        NewWS.Range("C20") = Application.WorksheetFunction.Sum(RngE)
            
        NewWS.Range("D20").Formula = "=C20/B20"
        
        WS.ShowAllData
        WS.AutoFilterMode = False
        ThisWorkbook.Activate
        
        '---> Update WU-Staging-FBME
        'Date Col K
        DateCol = 11
        Set WS = Sheets("WU-Staging-FBME")

        '---> Filter Records where Date between SDate and ToDate
        WS.UsedRange.AutoFilter Field:=DateCol, Criteria1:=">=" & SDate, Operator:=xlAnd, Criteria2:="<=" & Todate
   
        '---> Affect to RngE the visible data
        Set RngE = WS.Range("AA:AA").SpecialCells(xlCellTypeVisible)
        NewWS.Range("B21") = Application.WorksheetFunction.Sum(RngE)

        Set RngE = WS.Range("AB:AB").SpecialCells(xlCellTypeVisible)
        NewWS.Range("C21") = Application.WorksheetFunction.Sum(RngE) / 2
        
        NewWS.Range("D21").Formula = "=C21/B21"
        NewWS.Range("D22").Formula = "=C22/B22"
        
        '---> Find the Coresponding figure in Sheet Final Report
        ThisWorkbook.Activate
        
        WS.ShowAllData
        WS.AutoFilterMode = False
        
        '---> Update Values to File 'Monthly-Totals-By-Year.xls'
        '---> open the graph file 'Monthly-Totals-By-Year.xls' set by gowflow on 24/2/2012
        On Error Resume Next
        Application.AutomationSecurity = msoAutomationSecurityForceDisable
        Application.EnableEvents = False
        Set GraphWb = Workbooks.Open(Filename:=gstFolderMonthlyTotalsFile & "Monthly-Totals-By-Year.xls")

        Application.EnableEvents = True
        If Err <> 0 Then
            '---> File was not found in the gstFolderMonthlyTotalsFile location or not named correctly. Exit
            MsgBox ("Graph file 'Monthly-Totals-By-Year.xls' was not found please create it or adjust file folder location then re-start this procedure.")
            Exit Sub
        End If
        On Error GoTo 0
        
        On Error Resume Next
        Set GraphWS = GraphWb.Worksheets(Format(Year(SDate)))
        If Err <> 0 Then
            '---> Year is not opened in 'Monthly-Totals-By-Year.xls' ask user to open it and Exit
            MsgBox ("In the Graph file 'Monthly-Totals-By-Year.xls' the year " & Year(SDate) & " is not opened yet. Please proceed to create this sheet then start this procedure again.")
            Exit Sub
        End If
        On Error GoTo 0
        
        '---> Year was found so Update values in proper columns
        '---> Find the Proper month Column
        Set cCell = GraphWS.Range("2:2").Find(what:=Format(SDate, "Mmm"), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
        If Not cCell Is Nothing Then
            
            '---> Update the values in the cCell.column
            '---> Visa Load USD
            GraphWS.Cells(5, cCell.Column) = NewWS.Range("B20")
            '---> Visa Fees USD
            GraphWS.Cells(6, cCell.Column) = NewWS.Range("C20")
            '---> WU Load USD
            GraphWS.Cells(7, cCell.Column) = NewWS.Range("B21")
            '---> WU Fees USD
            GraphWS.Cells(8, cCell.Column) = NewWS.Range("C21")
            
            '---> Save and Close Graph file
            GraphWb.Save
            GraphWb.Close
        Else
            '---> The Month was not found advise user and Exit
            MsgBox ("In the Graph file 'Monthly-Totals-By-Year.xls' the year " & Year(SDate) & ", the month " & Format(SDate, "Mmm") & " was not found. Please proceed to check the file and then start this procedure again.")
            Exit Sub
        End If
        
        '---> Save Workbook
        NewWb.Save
        NewWb.Activate
        
        '---> Check if there was data in the file if yes the update variables to send file if no kill the file saved
        MaxRow = NewWS.UsedRange.Rows.Count
        
        If MaxRow > 2 Then
            gstGenerateVisaName = NewWb.FullName
            gstGenerateVisaEmail = ""
            X = MsgBox("Workbook: '" & NewWorkB & "' has been successfully update. Please check workbook to ensure all data is accurate. After all modifications done please ensure file is saved to proceed to Next Step.", vbInformation, "Monthly Totals File")
        Else
            Application.DisplayAlerts = False
            NewWb.Close savechanges:=False
            Kill NewWorkB
            Application.DisplayAlerts = True
            gstGenerateVisaName = ""
            gstGenerateVisaEmail = ""
            MsgBox ("No Records were found ! nothing to Export.")
        End If
    End If
End If

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
                                            
                                            
                                            
                                            











                                            
                                                                                        
                                            

Open in new window

0
 
LVL 20

Expert Comment

by:ltlbearand3
ID: 40000791
That is quite a bit of code for an Excel Workbook.  I looked through the code and you declare a value of gstFolderToMonitor as a global variable, but you never set it to anything.  This is used to get the value of FMonitor.  Since gstFolderToMonitor is blank then FMonitor is blank.  FMonitor is then passed to SetMonitorFolder when that Function is called.  Since FMonitor is blank, objFolderToMonitor is never instantiated (set to a value) and therefore will error whenever it is used.  

It appears that gstFolderToMonitor should be set as an Outlook Folder Path that you want monitored.  If this code worked in the past you may need to find an older copy of it to see how that value was set.  Otherwise you will need to determine what that value should be.
0
 

Author Comment

by:mabehr
ID: 40001326
I used an older version that use to work (and this one used to work as well) and I'm getting the same error. Any ideas on how to determine what the value is? I use Outlook to access a Gmail account using IMAP.
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 

Author Comment

by:mabehr
ID: 40001518
hi gowflow, any chance you can work on this one? Should be just a quick fix, I would think:

http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28411640.html#a39999893
0
 
LVL 20

Expert Comment

by:ltlbearand3
ID: 40003017
Ok,

I had to dig through several of your old posts to try and find out what you have happening.  I see this question and comments from gowflow that might help you out.  Right now it is very difficult for me to troubleshoot your code as you have not posted all the code and I don't have the workbook you are using.  You may have to step through the code to work back and find your missing information.
0
 

Author Comment

by:mabehr
ID: 40003875
I'm pretty sure it is an Outlook setting as another workbook I use - when trying to access Outlook - is giving me an error as well. And Outlook was reinstalled on my new hard drive as well as the Excel application.
0
 

Author Comment

by:mabehr
ID: 40003930
You mention you don't have all the code. What else would you need?
0
 
LVL 20

Accepted Solution

by:
ltlbearand3 earned 500 total points
ID: 40005683
Some of your other EE posts that appear to be related reference other modules that are not posted here.  Maybe you don't use them anymore, but I think they are part of Excel and they have not been posted yet.

This is not a setting in outlook.  Your code references a variable named gstFolderToMonitor, but that variable is never given a value in any of the code you have posted.  That variable has to be set somewhere in Excel for the code to work.  The link above that I reference from one of your other questions has some code that would set that value for you.  

If you can post the actual Excel workbook, then I can take a look and see what can be done to try and fix this code.  Otherwise, I am limited in how I can help.  There are pieces missing that would allow me to determine more what the code is supposed to do.
0
 

Author Closing Comment

by:mabehr
ID: 40008075
Found the problem. On my main page where I have all sorts of buttons and drop downs, which gowflow set up for me, I needed to change the destination of where the Outlook Folder to Monitor Email was set. I did that to reflect the new name I have my computer and it worked like a charm.

I'm very sorry  ltlbearand3 for you having to take the time on something that was right underneath my nose.
0

Featured Post

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

Drop Down List with Unique/Distinct Values (enhancing the Combo-Box with a few steps and a little code) David miller (dlmille) Intro Have you ever created a data validation list from a database field or spreadsheet column (e.g., Zip Codes or Co…
Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

760 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

26 Experts available now in Live!

Get 1:1 Help Now