VBA导入电子邮件内容到Excel – 运行时错误9

我在我们的网站上有一个表格，它会生成一个如下所示的电子邮件：

First Name: test Last Name: test Address1: test Address2: City: test State: CA Zip Code: 90032 Email: [e-mail] Telephone: Date of Birth: -Month- -Day- -Year- Marital Status: Purchase Month: April Purchase Day: -Day- Purchase Year: 2004 Purchase Place: test Purchase Place Other: Product type: test Other Product Type: Product size: test Other Product Size: Product color: test Did you buy this for yourself or received as a gift? self Which of the following product types do you own or intend to own? • Skillets & Grills • Specialty • Stockpots • Cast Iron Ovens & Braisers • Kettles • Bakeware • Kitchen Tools • Wine Tools Is this your first product? no What do you like to cook? • Slow Cooking • Kid Friendly Meals • Quick and Easy Would you like to receive email updates and special offers? yes comments: 

我试图把电子邮件的内容转换成excel，这样每一行都是一个列标题，用户提交的信息将进入标题下的行。 有时一个字段可能会留空（不是所有字段都是必需的）。 我发现这个post，并更新了表单字段以匹配我自己的表单和电子表格的path。 当我运行它，电子表格打开，但我得到“运行时错误9，下标超出范围消息。如果我点击debugging>切换断点，它突出显示第一行。

这是我正在使用的脚本。 任何人都可以审查和帮助使这项工作？ 我之前从未使用过macros或VBA，所以这对我来说都是陌生的。 我在网上search这个错误，但是我发现的一切都非常具体，对我没有帮助。 在 这里 ， 这里是我看过的几个例子。

  Option Explicit Sub CopyToExcel() Dim xlApp As Object Dim xlWB As Object Dim xlSheet As Object Dim olItem As Outlook.MailItem Dim vText As Variant Dim sText As String Dim vItem As Variant Dim i As Long Dim rCount As Long Dim bXStarted As Boolean Const strPath As String = "C:\Users\llantz\Desktop\prod-reg.xlsx" 'the path of the workbook 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)) '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), "First Name:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("B" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Last Name:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("C" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Address1:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("D" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Address2:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("E" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "City:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("F" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "State:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("G" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Zip Code:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("H" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Email:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("I" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Telephone:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("J" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Date of Birth:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("K" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Marital Status:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("L" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Purchase Month:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("M" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Purchase Day:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("N" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Purchase Year:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("O" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Purchase Place:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("P" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Purchase Place Other:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("P" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Product type:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("P" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Other Product Type:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("P" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Product size:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("P" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Other Product Size:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("P" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Product color:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("P" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Did you buy this for yourself or received as a gift?") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("P" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Which of the following product types do you own or intend to own?") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("Q" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Is this your first Le Creuset product?") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("Q" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "What do you like to cook?") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("Q" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Would you like to receive email updates and special offers from Le Creuset?") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("Q" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "comments:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("Q" & rCount) = Trim(vItem(1)) 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

在后面的一些项目中没有冒号，比如这个：

“你是自己买的还是收到的礼物？”

因此，用冒号（：，这是字符58）分割它只会创build一个单元数组：

 vItem = Split(vText(i), Chr(58)) 

在下一行中，尝试引用数组的第二个元素（拆分数组是基于零的，所以(vItem(1)是第二个元素）：

 xlSheet.Range("P" & rCount) = Trim(vItem(1)) 

由于没有第二个元素，你会得到“错误9 – 下标超出范围”。