将 Outlook 电子邮件导出到 Excel（使用 StackExchange 中的代码）答案

【问题标题】：Exporting Outlook Email to Excel (Used code from StackExchange)将 Outlook 电子邮件导出到 Excel（使用 StackExchange 中的代码）
【发布时间】：2020-06-30 20:10:57
【问题描述】：

我正在尝试创建一个将 Outlook 电子邮件迁移到 Excel 的程序。大约一年前，我在这个网站上找到了解决这个问题的方法，一切正常，直到电子邮件正文发生变化，我不得不更新代码。一起回到弗兰肯斯坦的一些代码，但现在我在 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”。我试图在网上找到这意味着什么，它可能是一个开环？但我关闭了如果。我只有使用 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

【问题讨论】：

编辑回滚。您可以接受答案并提出新问题。请参阅当有人回答我的问题时我应该怎么做？ stackoverflow.com/help/someone-answers 还有meta.stackoverflow.com/questions/305272/…

标签： excel vba email outlook

【解决方案1】：

您有两个 For Next 循环，其中“i”作为计数器。

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

和

For i = 0 To UBound(vPara)

这就是你的错误的根源。看来您最初使用“aa”计数了第二个循环。

【讨论】：

嗨！我接受了您的建议并将其放入。我更改了上面的问题，因为我遇到了其他问题！如果有机会，请看上面。
我是这个网站的新手，所以让我问一个可能看起来很菜的问题。听起来您所说的是我的答案有效，但是您没有接受它作为您问题的答案，而是更改了问题，现在需要对不同但相关的问题提供不同的答案。我知道这样做如何节省时间，因为基本信息是相同的。如果他们有一种方法来授予答案，然后可能会从原始帖子中分支另一个 Q，那就太好了。无论如何......我会看看它。
见meta.stackoverflow.com/questions/305272/…也见stackoverflow.com/help/someone-answers
你好！我没有意识到我所做的是违反 stackoverflow 元规则。我也是这个网站的新手！我不接受您的回答作为我问题的最佳答案的原因是因为它与复制和粘贴问题有关，该问题仅存在于我的原始代码的一半中。当我复制完整的代码时，我忘记更新我已将迭代器变量切换为 aa，我很抱歉造成混淆。我可以把你的问题作为答案，因为它确实在技术上回答了我原来的问题（这仍然存在于第一篇文章中）。