Outlook VBA set focus on Opened Workbook

I was having a tough time getting my code to work when I had all of it living in Outlook.

Here's the Outlook code to take apart the subject line and body and then summon Excel.

'declare mail item
Dim Item As MailItem
'declare excel
Dim xlApp As Excel.Application
'declare workbook
Dim xlWB As Excel.Workbook
'declare worksheet
Dim xlSheet As Excel.Worksheet

'Determine path of the destination
Const strPath As String = "C:\TEST.xlsm" ' workbook path and name
'If nothing selected
If Application.ActiveExplorer.Selection.Count = 0 Then
    'MsgBox "No Items selected! Dingus, pick an email!!!", 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")
    xlApp.Visible = True

    bXStarted = True
End If

On Error GoTo 0

Set xlWB = xlApp.Workbooks.Open(strPath)
    On Error GoTo ErrClose

Set xlSheet = xlWB.Sheets("Renewals List")


For Each Item In Application.ActiveExplorer.Selection
    

        Subj = Item.Subject
        'MsgBox "Subj " & Subj
        On Error GoTo SubjErr1

        'Subject Format: RE: FName, LName EDT(Plan of care renewal/Level of care renewal) R#
        
        'Split into 4s. 1. RE, 2. FName, 3. LName. 4, Plan & R#
        Subj = Split(Subj, " ", 4)
        'MsgBox "Split Subj into 4s... " & Subj(1) & " " & Subj(2)
        On Error GoTo SubjErr2
        
        'Split Subj into JUST client FNAME, LNAME
        NameSubj = (Subj(1)) & " " & (Subj(2)) ' was Subj1 & Com & " " & Subj2
        'MsgBox "NameSubj combine " & NameSubj
        On Error GoTo NameSubjErr1
        
        Dim NameSubjb As Variant
        
        On Error GoTo NameSubjErr2
        NameSubjb = Split(NameSubj, " ", 2)
        'MsgBox "NameSubjb variant " & NameSubjb
        
'        'Reverse order of names, LNAME, FNAME
'        On Error GoTo NameSubjErr3
        Dim NameSubjc As Variant
        NameSubjc = (NameSubjb(1) & " " & NameSubjb(0))
        'MsgBox "Reversed order of NameSubj " & NameSubjc
        NameSubj = NameSubjc
        
        'Split Subj3 into EDTSubj, determine EDT...
        On Error GoTo EDTSubjErr1
        EDTSubj = Left(Subj(3), 22)
        'MsgBox "EDTSubj " & EDTSubj
        
        
        'Split EDTSubj into two, ideally "Plan_" & the rest of the string, or "Level_" & the rest of the string...
        On Error GoTo EDTSubjErr2
        EDTSubjTest = Split(EDTSubj, " ", 2)
        'MsgBox "Test EDTSubj " & EDTSubjTest(0) & " " & EDTSubjTest(1)
        
            
            'If EDTSubjTest1 = Plan Then its Plan of care...
            If EDTSubjTest(0) = "Plan" Then
            EDTSubj = Left(Subj(3), 20) ' split for 20 characters, Plan of care renewal = 20 chars
            ElseIf EDTSubjTest(0) = "Application" Then ' Else, if Level, split 21 chars...
            EDTSubj = Left(Subj(3), 20) ' Application renewal = 20 chars
            End If
                
                'I didn't realize this until a day later but I didn't ever trim the spaces off of any other string...
                Dim EDTTrim As String
                EDTTrim = Trim(EDTSubj)
                
                'Make the trimmed string back into the real var.
                EDTSubj = EDTTrim
            


        On Error GoTo BodTErr1
        BodT = Item.Body
        'MsgBox "BodT " & Item.Body
        On Error GoTo BodTErr2
        BodT = Split(BodT, vbCr, 2)
        
        On Error GoTo BodTErr3
        BodT(0) = Replace(BodT(0), " ", "")
        
        On Error GoTo BodTErr4
        BodT(0) = Replace(BodT(0), vbLf, "")
        
        On Error GoTo BodTErr5
        BodT(0) = Replace(BodT(0), vbCr, "")
        
        On Error GoTo RNumErr
        RNum = Right(Subj(3), 2)
        
            'Yes - 3
            'No - 2
            'Yes, it has been submitted - 29
            'No, but I am on time - 20
            'No, and I need some help - 25
        
        On Error GoTo 0
        
        'BodT = CC response in words, NameSubj = Lname, Fname, EDTSubj = EDT, RNum = RNum
        MsgBox "BodT Value: " & BodT(0) & " NameSubj: " & NameSubj & " EDTSubj: " & EDTSubj & " RNum: " & RNum
        
        xlWB.Application.Run "Update", NameSubj, EDTSubj, BodT(0), RNum

        

        
'Elect next mail item
Next Item

Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set Item = Nothing

Exit Sub

ErrClose:

Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set Item = Nothing

SubjErr1:
    MsgBox "Faield to bind to .Subject property of " & Item
    Exit Sub

SubjErr2:
    MsgBox "Failed to split .Subject property of " & Item
    Exit Sub

NameSubjErr1:
    MsgBox "Failed to combine Subj(1) with Subj(2) Subj1 <" & Subj(1) & "> Subj2 <" & Subj(2) & ">"
    Exit Sub
    
NameSubjErr2:
    MsgBox "Failed to split NameSubj on space " & NameSubj
    Exit Sub
    
'NameSubjErr3:
'    MsgBox "Failed to reverse order of NameSubj " & NameSubj
'    Exit Sub
    
EDTSubjErr1:
    MsgBox "Failed to Split EDTSubj " & EDTSubj
    Exit Sub
    
EDTSubjErr2:
    MsgBox "Faield to Split EDTSubj by 2 spaces " & EDTSubjTest
    Exit Sub
    
BodTErr1:
    MsgBox "Failed to bind to the .Body property of " & Item
    Exit Sub
    
BodTErr2:
    MsgBox "Faield to Split BodT " & BodT
    Exit Sub
    
BodTErr3:
    MsgBox "Failed to replace " & BodT(0) & " -space- with -no space-"
    Exit Sub
    
BodTErr4:
    MsgBox "Failed to replace " & BodT(0) & " vbLineFeed with -no space-"
    Exit Sub
    
BodTErr5:
    MsgBox "Failed to replace " & BodT(0) & " vbCarriageReturn with -no space-"
    Exit Sub
    
RNumErr:
    MsgBox "Failed to store Rnum var."
    Exit Sub