title: How to extract email message and fill spreadsheet with values
body: <p>I have a macro that reads the unread messages in my inbox and extracts the data from the message with a delimiter of ":" . In the loop I want to be able to load the new excel spreadsheet with the values from the message.  </p>
  
  <p>I am able to select the first cell and save the data but it is getting over written. each time in the loop I want the data to go to the next cell in the column that is empty instead of overwriting the same cell.  </p>
  
  <p>Here is my code so far...</p>
  
  <pre><code>Public Sub Application_NewMail()
  
  Dim newbk As Workbook
  Set newbk = Workbooks.Add
  newbk.SaveAs "C:\Users\RickG\Desktop\test2.xlsx"  'other parameters can  be set here if required
  ' perform operations on newbk
  newbk.Close savechanges:=True
  
  Dim ns As Outlook.NameSpace
  Dim InBoxFolder As MAPIFolder
  Dim InBoxItem As Object 'MailItem
  Dim Contents As String, Delimiter As String
  Dim Prop, Result
  Dim i As Long, j As Long, k As Long
  
  'Setup an array with all properties that can be found in the mail
  Prop = Array("Name", "Email", "Phone", "Customer Type", _
  "Message")
  'The delimiter after the property
  Delimiter = ":"
  
   Set ns = Session.Application.GetNamespace("MAPI")
  
  
  'Access the inbox folder
  Set InBoxFolder = ns.GetDefaultFolder(olFolderInbox)
  
  Dim xlApp As Excel.Application
  Dim xlWB As Excel.Workbook
  Dim ws As Worksheet
  
  Set xlApp = New Excel.Application
  With xlApp
      .Visible = False
      Set xlWB = .Workbooks.Open("C:\Users\RickG\Desktop\test2.xlsx", , False)
      Set ws = .Worksheets("Sheet1")
   End With
  Dim LR As Long
  
  For Each InBoxItem In InBoxFolder.Items
  
  'Only process mails
  If Not TypeOf InBoxItem Is MailItem Then GoTo SkipItem
  'Skip wrong subjects
  If InStr(1, InBoxItem.Subject, "FW: New Lead - Consumer - Help with Medical Bills", vbTextCompare) = 0 Then GoTo SkipItem
  'Already processed?
  If Not InBoxItem.UnRead Then GoTo SkipItem
  'Mark as read
  InBoxItem.UnRead = False
  'Get the body
  Contents = InBoxItem.Body
  'Create space for the result
  ReDim Result(LBound(Prop) To UBound(Prop)) As String
  'Search each property
  i = 1
  
  For k = LBound(Prop) To UBound(Prop)
  
    'Find the property (after the last position)
    i = InStr(i, Contents, Prop(k), vbTextCompare)
    If i = 0 Then GoTo NextProp
    'Find the delimiter after the property
    i = InStr(i, Contents, Delimiter)
    If i = 0 Then GoTo NextProp
    'Find the end of this line
    j = InStr(i, Contents, vbCr)
    If j = 0 Then GoTo NextProp
    'Store the related part
    Result(k) = Trim$(Mid$(Contents, i + Len(Delimiter), j - i - Len(Delimiter)))
    'for every row, find the first blank cell and select it
  'MsgBox Result(k)
  LR = Range("A" &amp; Rows.Count).End(xlUp).Row
  Range("A" &amp; LR).Value = Result(k)
    'Update the position
    i = j
  
  NextProp:
  Next
  
  xlApp.DisplayAlerts = False
  xlWB.SaveAs ("C:\Users\RickG\Desktop\test2.xlsx")
  xlWB.Close
  xlApp.Quit
  
  If MsgBox(Join(Result, vbCrLf), vbOKCancel, "Auto Check In") = vbCancel Then Exit Sub
  SkipItem:
  Next
  
  End Sub
  </code></pre>