title: Exporting Outlook Email to Excel (Used code from StackExchange)
body: <p>I am trying to create a program that migrates Outlook emails to excel. I found a solution to this problem about a year ago on this site, and everything worked fine until the body of the email changed and I had to update the code. Came back here to Frankenstein some code together, but am now getting errors that go over my head in VBA.</p>
  
  <p>The emails look like this (the numbers are added for reference and to make the structure the same, they are not in the emails):</p>
  
  <ol>
  <li>Name: </li>
  <li>Do you currently reside in the United States? </li>
  <li>Address:</li>
  <li>City: </li>
  <li>State: </li>
  <li>Zip Code: </li>
  <li>Phone: </li>
  <li>Email: </li>
  <li>Citizenship: </li>
  <li>Grade: </li>
  <li>Essay Word Count: </li>
  <li>School / Organization Name: Teacher Name: Teacher Email: Is your school / sponsoring organization based in the United States?  School / Organization Address:  School / Organization City:  School / Organization State:  School / Organization Zip Code:  School / Organization Phone:  School / Organization Email:  How did you find out about this contest?  Essay Document:</li>
  </ol>
  
  <p>The old code worked up until the paragraph. So I found new code to run through paragraph and just added it on</p>
  
  <p>Old code:</p>
  
  <pre><code>Sub CopyToExcel()
  Dim xlApp As Object
  Dim xlWB As Object
  Dim xlSheet As Object
  Dim olItem As Outlook.MailItem
  Dim vText As Variant
  Dim vPara As Variant
  Dim sText As String
  Dim vItem As Variant
  Dim i As Long
  Dim aa As Long
  Dim rCount As Long
  Dim sLink As String
  Dim bXStarted As Boolean
  Const strPath As String = " " 'the path of the workbook- HERE IS WHERE YOU CHANGE THE LOCATION OF THE SPREADSHEET
  
  If Application.ActiveExplorer.Selection.Count = 0 Then
  MsgBox "No Items selected!", vbCritical, "Error"
  Exit Sub
  End If
  On Error Resume Next
  Set xlApp = GetObject(, "Excel.Application")
  If Err &lt;&gt; 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("Sheet1")
  
  'Process each selected record
  For Each olItem In Application.ActiveExplorer.Selection
  sText = olItem.Body
  vText = Split(sText, Chr(13))
  vPara = Split(sText, Chr(13))
  'Find the next empty line of the worksheet
  rCount = xlSheet.UsedRange.Rows.Count
  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), "Name:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("A" &amp; rCount) = Trim(vItem(1))
      End If
      If InStr(1, vText(i), "Do you currently reside in the United States?") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("B" &amp; rCount) = Trim(vItem(1))
      End If
      If InStr(1, vText(i), "Address:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("C" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Address 2:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("D" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "City:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("E" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "State:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("F" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Zip Code:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("G" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Country:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("H" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Phone:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("I" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Email:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("J" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Citizenship:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("K" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Grade:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("L" &amp; rCount) = Trim(vItem(1))
      End If
      If InStr(1, vText(i), "Essay Word Count:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("M" &amp; rCount) = Trim(vItem(1))
      End If
  </code></pre>
  
  <p>Here is the new paragraph part that I added</p>
  
  <pre><code>For aa = 0 To UBound(vPara)
      If InStr(1, vPara(aa), "School / Organization Name: ") &gt; 0 Then
          rCount = xlSheet.Range("N" &amp; xlSheet.Rows.Count)
          rCount = rCount + 1
          vText = Split(vPara(i), Chr(58))
          vItem = Split(vText(2) &amp; vText(3), ChrW(34))
          xlSheet.Range("N" &amp; rCount) = Trim(vItem(1))
          xlSheet.Range("O" &amp; rCount) = Trim(Replace(vText(1), "Teacher Name: ", ""))
          xlSheet.Range("P" &amp; rCount) = Trim(Replace(vText(4), "Teacher Email", ""))
          xlSheet.Range("Q" &amp; rCount) = Trim(Replace(vText(5), " Is your school / sponsoring    organization based in the United States?", ""))
          xlSheet.Range("R" &amp; rCount) = Trim(Replace(vText(6), " School / Organization Address: ", ""))
          xlSheet.Range("S" &amp; rCount) = Trim(Replace(vText(7), " School / Organization City: ", ""))
          xlSheet.Range("T" &amp; rCount) = Trim(Replace(vText(8), " School / Organization State: ", ""))
          xlSheet.Range("U" &amp; rCount) = Trim(Replace(vText(9), " School / Organization Zip Code: ", ""))
          xlSheet.Range("V" &amp; rCount) = Trim(Replace(vText(9), " School / Organization Phone: ", ""))
          xlSheet.Range("W" &amp; rCount) = Trim(Replace(vText(9), " School / Organization Email: ", ""))
          xlSheet.Range("X" &amp; rCount) = Trim(Replace(vText(9), " How did you find out about this contest? ", ""))
          xlSheet.Range("Y" &amp; rCount) = Trim(Replace(vText(9), " Essay Document: ", ""))
          xlSheet.Range("Z" &amp; rCount) = Trim(vText(10))
      End If
  
  Next aa
  xlWB.Save
  Next olItem
  xlWB.Close SaveChanges:=True
  If bXStarted Then
  xlApp.Quit
  End If
  Set xlApp = Nothing
  Set xlWB = Nothing
  Set xlSheet = Nothing
  Set olItem = Nothing
  End Sub
  </code></pre>
  
  <p>First, does this even attempt to do what I am doing? Second off, when I debug it in VBA, it throws an error at Next olItem, saying "Invalid Next control variable reference". I tried to find what that meant online, and it might be an open loop? But I close the if. I only have experience coding with Python and Java, so it may be a syntax problem and my unfamiliarity. </p>
  
  <p>Full Code
      Option Explicit</p>
  
  <pre><code>Sub CopyToExcel()
  Dim xlApp As Excel.Application
  Dim xlWB As Excel.Workbook
  Dim xlSheet As Excel.Worksheet
  Dim olItem As Outlook.MailItem
  Dim vText As Variant
  Dim vPara As Variant
  Dim sText As String
  Dim vItem As Variant
  Dim oRng As Range
  Dim i As Long
  Dim rCount As Long
  Dim sLink As String
  Dim bXStarted As Boolean
  Const strPath As String =  "C:\Users\Awardsintern\Documents\StudentInfo.xlsx" 'the path of the workbook-  HERE IS WHERE YOU CHANGE THE LOCATION OF THE SPREADSHEET
  
  If Application.ActiveExplorer.Selection.Count = 0 Then
  MsgBox "No Items selected!", vbCritical, "Error"
  Exit Sub
  End If
  On Error Resume Next
  Set xlApp = GetObject(, "Excel.Application")
  If Err &lt;&gt; 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("Sheet1")
  
  'Process each selected record
  For Each olItem In Application.ActiveExplorer.Selection
  sText = olItem.Body
  vText = Split(sText, Chr(13))
  vPara = Split(sText, Chr(13))
  'Find the next empty line of the worksheet
  rCount = xlSheet.UsedRange.Rows.Count
  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), "Name:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("A" &amp; rCount) = Trim(vItem(1))
      End If
      If InStr(1, vText(i), "Do you currently reside in the United States?") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("B" &amp; rCount) = Trim(vItem(1))
      End If
      If InStr(1, vText(i), "Address:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("C" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Address 2:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("D" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "City:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("E" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "State:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("F" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Zip Code:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("G" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Country:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("H" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Phone:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("I" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Email:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("J" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Citizenship:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("K" &amp; rCount) = Trim(vItem(1))
      End If
  
      If InStr(1, vText(i), "Grade:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("L" &amp; rCount) = Trim(vItem(1))
      End If
      If InStr(1, vText(i), "Essay Word Count:") &gt; 0 Then
          vItem = Split(vText(i), Chr(58))
          xlSheet.Range("M" &amp; rCount) = Trim(vItem(1))
      End If
  
  For i = 0 To UBound(vPara)
      If InStr(1, vPara(i), "School / Organization Name: ") &gt; 0 Then
          rCount = xlSheet.Range("N" &amp; xlSheet.Rows.Count).End(xlUp).Row
          rCount = rCount + 1
          vText = Split(vPara(i), Chr(58))
          vItem = Split(vText(2) &amp; vText(3), ChrW(34))
          xlSheet.Range("N" &amp; rCount) = Trim(vItem(1))
          xlSheet.Range("O" &amp; rCount) = Trim(Replace(vText(1), "Teacher Name: ", ""))
          xlSheet.Range("P" &amp; rCount) = Trim(Replace(vText(4), "Teacher Email", ""))
          xlSheet.Range("Q" &amp; rCount) = Trim(Replace(vText(5), " Is your school / sponsoring    organization based in the United States?", ""))
          xlSheet.Range("R" &amp; rCount) = Trim(Replace(vText(6), " School / Organization Address: ", ""))
          xlSheet.Range("S" &amp; rCount) = Trim(Replace(vText(7), " School / Organization City: ", ""))
          xlSheet.Range("T" &amp; rCount) = Trim(Replace(vText(8), " School / Organization State: ", ""))
          xlSheet.Range("U" &amp; rCount) = Trim(Replace(vText(9), " School / Organization Zip Code: ", ""))
          xlSheet.Range("V" &amp; rCount) = Trim(Replace(vText(9), " School / Organization Phone: ", ""))
          xlSheet.Range("W" &amp; rCount) = Trim(Replace(vText(9), " School / Organization Email: ", ""))
          xlSheet.Range("X" &amp; rCount) = Trim(Replace(vText(9), " How did you find out about this contest? ", ""))
          xlSheet.Range("Y" &amp; rCount) = Trim(Replace(vText(9), " Essay Document: ", ""))
          xlSheet.Range("Z” &amp; rCount) = Trim(vText(10))
      End If
  
  Next i
  xlWB.Save
  Next olItem
  xlWB.Close SaveChanges:=True
  If bXStarted Then
  xlApp.Quit
  End If
  Set xlApp = Nothing
  Set xlWB = Nothing
  Set xlSheet = Nothing
  Set olItem = Nothing
  End Sub
  </code></pre>