Sub CopyToExcel()
 Dim olItem As Outlook.MailItem
 Dim xlApp As Excel.Application
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim vText, vText2, vText3, vText4, vText5 As Variant
 Dim sText As String
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String
 
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
 strPath = enviro & "\Documents\test.xlsx"
     On Error Resume Next
     Set xlApp = New 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("Test")
    ' Process the message record
    Set olItem = Application.ActiveExplorer().Selection(1)
    
    'Find the next empty line of the worksheet
     rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
     rCount = rCount + 1
     
     sText = olItem.Body
     
    Dim Reg1 As RegExp
    Dim M1 As MatchCollection
    Dim M As Match
              
    Set Reg1 = New RegExp
     
    ' \s* = invisible spaces
    ' \d* = match digits
    ' \w* = match alphanumeric
     
    With Reg1
        .Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*(\d))"
    End With
    If Reg1.test(sText) Then
     
        Set M1 = Reg1.Execute(sText)
        For Each M In M1
           vText = Trim(M.SubMatches(1))
           vText2 = Trim(M.SubMatches(2))
           vText3 = Trim(M.SubMatches(3))
           vText4 = Trim(M.SubMatches(4))
           vText5 = Trim(M.SubMatches(5))
        Next
    End If

  xlSheet.Range("B" & rCount) = vText
  xlSheet.Range("c" & rCount) = vText2
  xlSheet.Range("d" & rCount) = vText3
  xlSheet.Range("e" & rCount) = vText4
  xlSheet.Range("f" & rCount) = vText5

     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
 End Sub