我正在尝试创建一个将Outlook电子邮件迁移到Excel的程序。大约一年前，我在这个网站上找到了这个问题的解决方案，一切正常，直到电子邮件正文发生变化，我不得不更新代码。回到这里给Frankenstein一些代码，但现在我在VBA中遇到了错误。
电子邮件看起来像这样（添加数字以供参考，并使结构相同，它们不在电子邮件中）：
旧代码一直工作到该段落。所以我找到了新的代码来运行段落并将其添加到
旧代码：
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中调试它时，它会在Next olItem中抛出一个错误，说“Invalid Next control variable reference”。我试图在网上找到这意味着什么，它可能是一个开环？但我关闭了if。我只有使用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
答案 0 :(得分：1)
你有两个For Next循环，其中“i”作为你的计数器。
For i = UBound(vText) To 0 Step -1
和
For i = 0 To UBound(vPara)
这是您错误的来源。您似乎最初使用“aa”计算第二个循环。