Some issue with this Outlook VBA.

[jobs123]

Hello All,

I have got a VBA script in outlook which checks for the subject of the mail if it contains some text and then checks whether or not that text is present in an already exisitng excel sheet.If it is present then it will update another excel sheet with the subject,body.Ann if that text is not present in that sheet then it will not upadte that another sheet.

But what is happening is it is updating that new sheet if that text is not present also in the exisiting excel sheet which is taking from the subject.And one more thing is that this script is running only on my system,not working on any other system.
I am attaching the VBA code for reference.

Function CheckText(CellToCheck As Range, KeyString As String) As Boolean
    Dim CheckRange As Range, Hit As Range
    Set Hit = CellToCheck.Find(what:=KeyString, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
    CheckText = Not (Hit Is Nothing)
End Function
 
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim CheckRange As Range
Dim KeyString As String
vID = Split(EntryIDCollection, ",")
Set XLApp1 = CreateObject("Excel.Application")
Set CheckRange = XLApp1.Workbooks.Open("C:\Users\vijaywp\Desktop\India-IR-Schedule.xlsx").Sheets("Client Testing").Range("A1:S100")
For i = 0 To UBound(vID)
Set objMail = Application.Session.GetItemFromID(vID(i))
vSubject = objMail.Subject
vBody = objMail.Body
vFrom = objMail.SenderEmailAddress
VRtime = objMail.SentOn
KeyString = Mid(Trim(Mid(vSubject, InStr(vSubject, "#") + 1)), 1, 3)
If CheckText(CheckRange, KeyString) = True Then
 
   Set XLApp = CreateObject("Excel.Application")
   Set xlWB = XLApp.Workbooks.Open("C:\Users\vijaywp\Desktop\sample.xlsx")
   Set xlSheet = xlWB.Sheets("Sheet1")
   vRow = xlSheet.Range("A" & XLApp.Rows.Count).End(-4162).Offset(1, 0).Row
   xlSheet.Range("A" & vRow).Value = vSubject
   xlSheet.Range("B" & vRow).Value = vBody
   xlSheet.Range("C" & vRow).Value = VRtime
   xlWB.Save
   XLApp.Quit
   Set objMail = Nothing
   Set XLApp = Nothing
 
End If
Next i
XLApp1.DisplayAlerts = False
XLApp1.Quit
XLApp1.DisplayAlerts = True
Set XLApp1 = Nothing
End Sub

Please help me on this one guys.

Thanks in advance.