Related Question - ID: 39880730 Outlook Rule Runs vb Code

I am making progress on implementing a solution based on the excellent input I got on the 1st question.

I adapted this code trying to open excel and search for a matching email then select the folder name (or names) for each instance of that email and append that to the contact item in outlook.

Two issues:
  1) Opening and searching excel like I do is slow - I wonder if there is a faster way to search a list?
 2) I added the "On Error GoTo NoContactFound"  line because the code was failing at "If objContact.Class = olContact Then" when there was no matching email address in the contacts folder - now id doesn't find the email matches but jumps to the end.

Sub MyRule(Item As Outlook.MailItem)
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objContact As Outlook.ContactItem
    Dim objItems As Outlook.Items
    Dim objContactsFolder As Outlook.MAPIFolder
    Dim obj As Object
    
    Dim NameFilter As String, strFile As String, i As Integer
   
    Dim RowNo As Integer, MaxRows As Integer
    
    Set xlApp = CreateObject("Excel.Application")

    If xlApp = "Microsoft Excel" Then
    
    Else
        With xlApp
            .Visible = True
            .EnableEvents = False
        End With
    End If
    
    strFile = "C:\Personal\OutlookData\OutlookRuleFileEmails.xlsm"
On Error GoTo openit
    If sourceWB.Name <> "OutlookRuleFileEmails.xlsm" Then
openit:
        Set sourceWB = xlApp.Workbooks.Open(strFile) ', , False, , , , , , , True)
        Set sourceWS = sourceWB.Worksheets("EmailRule")
        sourceWB.Activate
    End If
    
    Set objOL = CreateObject("Outlook.Application")
    Set objNS = objOL.GetNamespace("MAPI")
    Set objContactsFolder = objNS.GetDefaultFolder(olFolderContacts)
    Set objItems = objContactsFolder.Items

    NameFilter = "[Email1Address] = " & """" & Item.SenderEmailAddress & """"
    
    Set objContact = objItems.Find(NameFilter)
    
On Error GoTo NoContactFound
    
        If objContact.Class = olContact Then
        
'-----------------
MsgBox "First " & vbNewLine & Item.Subject & vbNewLine & Item.SenderEmailAddress & vbNewLine & NameFilter & vbNewLine & objContactsFolder.Name & vbNewLine & objContact.Email1Address & vbNewLine & Format(Item.ReceivedTime, "mm/dd/yyyy") & vbNewLine & sourceWS.Cells(i, 2) & vbNewLine & sourceWS.Cells(i, 3) & vbNewLine & i
            RowNo = 1
            MaxRows = sourceWS.Cells(1, 1)
        
            While RowNo <= MaxRows
                    MsgBox "Second " & vbNewLine & Item.Subject & vbNewLine & Item.SenderEmailAddress & vbNewLine & NameFilter & vbNewLine & objContactsFolder.Name & vbNewLine & objContact.Email1Address & vbNewLine & Format(Item.ReceivedTime, "mm/dd/yyyy") & vbNewLine & sourceWS.Cells(i, 2) & vbNewLine & sourceWS.Cells(i, 3) & vbNewLine & i
                
                If Item.SenderEmailAddress = sourceWS.Cells(i, 2) Then
                    MsgBox "Third " & vbNewLine & Item.Subject & vbNewLine & Item.SenderEmailAddress & vbNewLine & NameFilter & vbNewLine & objContactsFolder.Name & vbNewLine & objContact.Email1Address & vbNewLine & Format(Item.ReceivedTime, "mm/dd/yyyy") & vbNewLine & sourceWS.Cells(i, 2) & vbNewLine & sourceWS.Cells(i, 3) & vbNewLine & i
                    objContact.Body = objContact.Body & vbNewLine & "--------------------" & vbNewLine & Format(Item.ReceivedTime, "mm/dd/yyyy") & " " & Item.Subject & vbNewLine & sourceWS.Cells(i, 3)
                    objContact.Save
                End If
                
                RowNo = RowNo + 1
            Wend
        End If
NoContactFound:
MsgBox "NoContactFound" & vbNewLine & NameFilter
End Sub

Select allOpen in new window

I'm learning, searching the internet for help, but after a couple of hrs. trying to solve this one I'm stumped