Outlook Email to Excel with VBA

  • Hi Folks,
    I am trying to modify some code I found to meet my needs. The code works to pull over the information I am looking to move to Excel but needs a bit of fine tuning to manage the process flow. It currently only works on selected emails and does not move the emails to a "completed" folder. I am looking to change it as follows:
    1. Find all emails in my Inbox (this is not a shared box) where the email was sent by "PSQACE" with the subject being "SO Approval Request".
    2. Pull the body data shown in the code into the existing Excel TEST.XLSX file (this part of the code works fine).
    3. Move those emails used in step 1 & 2 above into an existing subfolder (SOApprvlDone) under Inbox.


    The code will be run manually by me as needed. If a button or something can be put on the ribbon to run it that would be a treat, but not absolutely necessary.
    I know the movement of the files can be done via a rule, but as the VBA will be processing each of the targeted emails anyway I am thinking the use of a rule being manually run after the VBVA is completed would be a separate and additional step that may be forgotten leading to duplication of records in Excel.
    I am not in any way skilled in VBA so any help would be greatly appreciated!


    CODE
    Option Explicit
    Sub CopyToExcel()


    'microsoft developer network
    'Export Content form Outlook emails to excel spreadsheet

    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim msg As Outlook.MailItem
    Dim vdate As Date
    Const strPath As String = "C:\Users\USS46861\Award Tracking\test.xlsx" 'the path of the workbook



    If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "No Items selected!", vbCritical, "Error"
    Exit Sub
    End If
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
    Application.StatusBar = "Please wait while Excel source is opened ... "
    Set xlApp = CreateObject("Excel.Application")
    bXStarted = True
    End If
    On Error GoTo 0
    'Open the workbook to input the data
    Set xlWB = xlApp.Workbooks.Open(strPath)
    Set xlSheet = xlWB.Sheets("Sheet1")


    'Process each selected record
    rCount = xlSheet.UsedRange.Rows.Count
    For Each olItem In Application.ActiveExplorer.Selection
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    vdate = olItem.ReceivedTime
    'Find the next empty line of the worksheet
    rCount = rCount + 1
    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1
    If InStr(1, vText(i), "Source:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("A" & rCount) = Trim(vItem(1))
    End If


    If InStr(1, vText(i), "Salesperson:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("d" & rCount) = Trim(vItem(1))
    End If


    If InStr(1, vText(i), "Account:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("e" & rCount) = Trim(vItem(1))
    End If


    If InStr(1, vText(i), "Account Classification:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("f" & rCount) = Trim(vItem(1))
    End If


    If InStr(1, vText(i), "Customer PO:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("g" & rCount) = Trim(vItem(1))
    End If


    If InStr(1, vText(i), "Order Amount:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("h" & rCount) = Trim(vItem(1))
    End If

    'Enters Email received date of request for approval into Excel
    xlSheet.Range("i" & rCount) = vdate



    Next i
    xlWB.Save
    Next olItem
    ' xlWB.Close SaveChanges:=True
    'If bXStarted Then
    ' xlApp.Quit
    ' End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    Set olItem = Nothing
    End Sub
    /CODE