Hello

I have a problem with the code below. It works when I run it manually but when I add it to a script in outlook the cells in the spreadsheet are either blank or it will insert the cells from the previous record that was recieved. Its almost like the memory stores previous information.

Can anyone see why please?

Sub SupaCompare1()

Dim olitem As Outlook.MailItem

Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i, c As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "G:\Leads Email\SupaCompare.xlsx"
Const NewPath As String = "Z:\New Leads"
Dim FilePath As String

Dim Daye As String

Daye = Format(Now(), "mm.dd.yyyy hh.mm.ss")

    On Error Resume Next
    Set olitem = ActiveExplorer.Selection
    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("G:\Leads Email\SupaCompare.xlsx")
    Set xlSheet = xlWB.Sheets("sheet1")
    With xlApp
    .Visible = False
    .Range("$A$1").Value = "Source"
    .Range("$B$1").Value = "Subsource"
    .Range("$C$1").Value = "Title"
    .Range("$D$1").Value = "FirstName"
    .Range("$E$1").Value = "MiddleName"
    .Range("$F$1").Value = "Surname"
    .Range("$G$1").Value = "ResidentialStatus"
    .Range("$H$1").Value = "LoanAmount"
    .Range("$I$1").Value = "PropertyValuation"
    .Range("$J$1").Value = "MortgageBalance"
    .Range("$K$1").Value = "AddressLine1"
    .Range("$L$1").Value = "AddressLine2"
    .Range("$M$1").Value = "AddressLine3"
    .Range("$N$1").Value = "Town"
    .Range("$O$1").Value = "County"
    .Range("$P$1").Value = "Postcode"
    .Range("$Q$1").Value = "Purpose"
    .Range("$R$1").Value = "DateofBirth"
    .Range("$S$1").Value = "MaritalStatus"
    .Range("$T$1").Value = "EmailAddress"
    .Range("$U$1").Value = "PhoneNumberOther"
    .Range("$V$1").Value = "PhoneNumber"
    .Range("$W$1").Value = "OptInStatus"

    .Range("$A$2").Value = "SupaCompare"
    .Range("$B$2").Value = "N/A"
    End With
    c = 2
    'Process the message record
    For Each olitem In Application.ActiveExplorer.Selection
    sText = olitem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
    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), "Title:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("A" & c).Value = "SupaCompare"
        End If
        
        If InStr(1, vText(i), "Title:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("B" & c).Value = "N/A"
        End If
        
        If InStr(1, vText(i), "Title:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("C" & c).Value = Trim(vItem(1))
        End If
        
        If InStr(1, vText(i), "FirstName:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("D" & c).Value = Trim(vItem(1))
        End If
        
        If InStr(1, vText(i), "MiddleName:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("E" & c).Value = Trim(vItem(1))
        End If
        
        If InStr(1, vText(i), "Surname:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("F" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "ResidentialStatus:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("G" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "LoanAmount:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("H" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "PropertyValuation:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("I" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "MortgageBalance:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("J" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "AddressLine1:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("K" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "AddressLine2:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("L" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "AddressLine3:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("M" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Town:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("N" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "County:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("O" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Postcode:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("P" & c).Value = Trim(vItem(1))
        End If
        
        If InStr(1, vText(i), "Purpose:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("Q" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "DateOfBirth:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("R" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "MaritalStatus:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("S" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "EmailAddress:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("T" & c).Value = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "PhoneNumber:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("U" & c).Value = Format(Trim(vItem(1)), "'00000000000")
        End If

        If InStr(1, vText(i), "PhoneNumberOther:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("V" & c).Value = Format(Trim(vItem(1)), "'00000000000")
        End If

        If InStr(1, vText(i), "OptInStatus:") > 0 Then
            vItem = Split(vText(i), Chr(58))
'            Debug.Print Trim(vItem(1))
            xlSheet.Range("W" & c).Value = Trim(vItem(1))
        End If


    Next i
    c = c + 1
    
    Next olitem
    Set olitem = Nothing
    
    
With xlApp.Workbooks("SupaCompare.xlsx")
.SaveAs FileName:="Z:\New Leads\" & "SupaCompare_" & Daye & ".csv", FileFormat:=6
.Close savechanges:=False
End With

        If bXStarted Then
        xlApp.Quit
    End If

    Set vItem = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing

    
End Sub