导出Outlook电子邮件到Excel（从StackExchange使用的代码）

我正在尝试创build一个将Outlook电子邮件迁移到Excel的程序。 大约一年前，我在这个网站上发现了一个解决这个问题的办法，一切正常，直到电子邮件正文发生变化，我不得不更新代码。 回到这里弗兰肯斯坦一些代码在一起，但现在越来越错误，在我的头在VBA。

电子邮件看起来像这样（数字被添加作为参考，并使结构相同，他们不在电子邮件中）：

1. 名称：
2. 你目前居住在美国吗？
3. 地址：
4. 市：
5. 州：
6. 邮政编码：
7. 电话：
8. 电子邮件：
9. 国籍：
10. 年级：
11. 散文字数：
12. 学校/组织名称：教师姓名：教师电子邮件：您的学校/办学组织是否在美国？ 学校/组织地点：学校/组织所在城市：学校/组织所在州：学校/组织机构邮政编码：学校/组织电话：学校/组织电子邮件：您是如何知道本次比赛的？ 作文文件：

旧的代码直到这个段落。 所以我发现新的代码运行通过段落，只是把它添加

旧代码：

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 <> 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:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("A" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Do you currently reside in the United States?") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("B" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Address:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("C" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Address 2:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("D" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "City:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("E" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "State:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("F" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Zip Code:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("G" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Country:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("H" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Phone:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("I" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Email:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("J" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Citizenship:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("K" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Grade:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("L" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Essay Word Count:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("M" & rCount) = Trim(vItem(1)) End If 

这是我添加的新的段落部分

 For aa = 0 To UBound(vPara) If InStr(1, vPara(aa), "School / Organization Name: ") > 0 Then rCount = xlSheet.Range("N" & xlSheet.Rows.Count) rCount = rCount + 1 vText = Split(vPara(i), Chr(58)) vItem = Split(vText(2) & vText(3), ChrW(34)) xlSheet.Range("N" & rCount) = Trim(vItem(1)) xlSheet.Range("O" & rCount) = Trim(Replace(vText(1), "Teacher Name: ", "")) xlSheet.Range("P" & rCount) = Trim(Replace(vText(4), "Teacher Email", "")) xlSheet.Range("Q" & rCount) = Trim(Replace(vText(5), " Is your school / sponsoring organization based in the United States?", "")) xlSheet.Range("R" & rCount) = Trim(Replace(vText(6), " School / Organization Address: ", "")) xlSheet.Range("S" & rCount) = Trim(Replace(vText(7), " School / Organization City: ", "")) xlSheet.Range("T" & rCount) = Trim(Replace(vText(8), " School / Organization State: ", "")) xlSheet.Range("U" & rCount) = Trim(Replace(vText(9), " School / Organization Zip Code: ", "")) xlSheet.Range("V" & rCount) = Trim(Replace(vText(9), " School / Organization Phone: ", "")) xlSheet.Range("W" & rCount) = Trim(Replace(vText(9), " School / Organization Email: ", "")) xlSheet.Range("X" & rCount) = Trim(Replace(vText(9), " How did you find out about this contest? ", "")) xlSheet.Range("Y" & rCount) = Trim(Replace(vText(9), " Essay Document: ", "")) xlSheet.Range("Z" & 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 

首先，这是否甚至试图做我正在做的事情？ 其次，当我在VBA中debugging它时，它会在Next olItem处引发错误，并提示“Invalid Next control variable reference”。 我试图find网上的含义，这可能是一个开放的循环？ 但我closures了如果。 我只有使用Python和Java编码的经验，所以它可能是一个语法问题和我的陌生。

完整的代码选项显式

 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 <> 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:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("A" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Do you currently reside in the United States?") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("B" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Address:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("C" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Address 2:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("D" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "City:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("E" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "State:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("F" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Zip Code:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("G" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Country:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("H" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Phone:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("I" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Email:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("J" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Citizenship:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("K" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Grade:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("L" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Essay Word Count:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("M" & rCount) = Trim(vItem(1)) End If For i = 0 To UBound(vPara) If InStr(1, vPara(i), "School / Organization Name: ") > 0 Then rCount = xlSheet.Range("N" & xlSheet.Rows.Count).End(xlUp).Row rCount = rCount + 1 vText = Split(vPara(i), Chr(58)) vItem = Split(vText(2) & vText(3), ChrW(34)) xlSheet.Range("N" & rCount) = Trim(vItem(1)) xlSheet.Range("O" & rCount) = Trim(Replace(vText(1), "Teacher Name: ", "")) xlSheet.Range("P" & rCount) = Trim(Replace(vText(4), "Teacher Email", "")) xlSheet.Range("Q" & rCount) = Trim(Replace(vText(5), " Is your school / sponsoring organization based in the United States?", "")) xlSheet.Range("R" & rCount) = Trim(Replace(vText(6), " School / Organization Address: ", "")) xlSheet.Range("S" & rCount) = Trim(Replace(vText(7), " School / Organization City: ", "")) xlSheet.Range("T" & rCount) = Trim(Replace(vText(8), " School / Organization State: ", "")) xlSheet.Range("U" & rCount) = Trim(Replace(vText(9), " School / Organization Zip Code: ", "")) xlSheet.Range("V" & rCount) = Trim(Replace(vText(9), " School / Organization Phone: ", "")) xlSheet.Range("W" & rCount) = Trim(Replace(vText(9), " School / Organization Email: ", "")) xlSheet.Range("X" & rCount) = Trim(Replace(vText(9), " How did you find out about this contest? ", "")) xlSheet.Range("Y" & rCount) = Trim(Replace(vText(9), " Essay Document: ", "")) xlSheet.Range("Z” & 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 

Answer 1

你有两个“下一个”循环与“我”作为你的计数器。

 For i = UBound(vText) To 0 Step -1 

和

 For i = 0 To UBound(vPara) 

这是你的错误的来源。 看起来你最初有第二个循环与“aa”计数。