title: Reduce process time String decomposition
body: <p>I hope you can help me reduce the runtime of my code :</p>
  
  <pre><code>Dim position As Long
  Dim CellRow As Long
  CellRow = 2
  
  For position = InStr(Inbox.Items(MostRecentVersionIndex).body, "Name") To Len(Inbox.Items(MostRecentVersionIndex).body)
              ThisWorkbook.Sheets(1).Range("A" &amp; CellRow) = Mid(Inbox.Items(MostRecentVersionIndex).body, InStr(position, Inbox.Items(MostRecentVersionIndex).body, "SCA"), InStr(InStr(position, Inbox.Items(MostRecentVersionIndex).body, "SCA") + 1, Inbox.Items(MostRecentVersionIndex).body, "SCA") - InStr(position, Inbox.Items(MostRecentVersionIndex).body, "SCA"))
              CellRow = CellRow + 1
              position = InStr(InStr(position, Inbox.Items(MostRecentVersionIndex).body, "SCA") + 1, Inbox.Items(MostRecentVersionIndex).body, "SCA") - 1
          Next position 
  </code></pre>
  
  <ol>
  <li>The first part of the code was to find a specific email in Outlook and then I stored its index in <code>MostRecentVersionIndex</code>. (NOT shown above)</li>
  <li>This email has a massive amount of records in its body (about 0.5 million characters) and the second part of my code (shown above) consists in putting each single record in a new row of column A from Sheet 1 . I know that each record starts with "SCA" that's why I used it as a split parameter.</li>
  </ol>
  
  <p>Issue : It takes (unsurprisingly) about 10 minutes to run the whole thing.</p>
  
  <p>Any idea on how to reduce this ?</p>
  
  <p>EDIT : Here is FYI the whole code (AFTER THE UPDATE WITH THE SOLUTION) :</p>
  
  <pre><code>Sub MailFinder()
  '1)Finding the most recent mail from Mr. Spoke
      Dim Inbox As folder
      Dim i As Integer
      Dim MostRecentVersionIndex As Integer
      MostRecentVersionIndex = -1
      Dim TimeReceived As Date
      Dim Content As String
      Set Inbox = Session.GetDefaultFolder(olFolderInbox)
  
      For i = 1 To Inbox.Items.Count
  
              If TypeName(Inbox.Items(i)) &lt;&gt; "ReportItem" Then ' to avoid errors because we can't access information from this type of file
                  If Left(Inbox.Items(i).Subject, 24) = "Mr. Spoke Subject" Then 'And Inbox.Items(i).SenderName = "Mr.Spoke" Then
                        'MsgBox Len(Inbox.Items(i).body) '584512
                        If Inbox.Items(i).ReceivedTime &gt; TimeReceived Then
                              TimeReceived = Inbox.Items(i).ReceivedTime
                              MostRecentVersionIndex = i
                        End If
                        'ThisWorkbook.Sheets("Sheet2").Range("A1") = Inbox.Items(i).body ' only get 32000 characters
  
                  End If
              End If
      Next i
  
  '2)Retrieving its information and storing each line in a new row from column A
      Dim position As Long
      Dim CellRow As Long
      Dim RightMail As MailItem
      Set RightMail = Inbox.Items(MostRecentVersionIndex)
      Dim body As String
      body = RightMail.body
      CellRow = 2
      If MostRecentVersionIndex &lt;&gt; -1 Then
          ThisWorkbook.Sheets("SpokeSubject").Range("A1") = Left(body, InStr(body, "Name") + 3)
  
          For position = InStr(body, "Name") To Len(body)
              On Error GoTo Fin
              ThisWorkbook.Sheets("SpokeSubject").Range("A" &amp; CellRow) = Mid(body, InStr(position, body, "SCA"), InStr(InStr(position, body, "SCA") + 1, body, "SCA") - InStr(position, body, "SCA"))
              CellRow = CellRow + 1
              position = InStr(InStr(position, body, "SCA") + 1, body, "SCA") - 1
          Next position '209333
          'Inbox.Items(i).body.Copy ' doesn't work
          'ThisWorkbook.Sheets("Sheet2").Range("A1").PasteSpecial
          'ThisWorkbook.Sheets("Sheet2").Range("A1") = Inbox.Items(MostRecentVersionIndex).body ' all in one cell...
  Fin:
      End If
      Call Formatter
  End Sub
  </code></pre>