私たちのウェブサイトには、次のような電子メールを生成するフォームがあります。
First Name: test
Last Name: test
Address1: test
Address2:
City: test
State: CA
Zip Code: 90032
Email: test@yahoo.com
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 に取り込もうとしています。場合によっては、フィールドが空白のままになることがあります (すべてのフィールドが必須というわけではありません)。この投稿を見つけて、自分のフォームとスプレッドシートのパスに一致するようにフォーム フィールドを更新しました。実行すると、スプレッドシートが開きますが、「実行時エラー 9、添え字が範囲外です」というメッセージが表示されます。 [デバッグ] > [ブレークポイントの切り替え] をクリックすると、最初の行が強調表示されます。
これが私が使用しているスクリプトです。誰でもレビューして、これを機能させるのを手伝ってもらえますか? 私はこれまでマクロや VBA を使用したことがないので、これは私にとってまったくなじみのないことです。このエラーをオンラインで検索しましたが、見つかったものはすべて非常に具体的であり、役に立ちません。 ここ、ここ、およびここに、私が見たもののいくつかの例を示します。
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