无法让VB脚本在Excel文档中添加新行

首先，我会说我是新来的VB …我有一个脚本，我使用，由于某种原因不能得到它从多个电子邮件添加到新行的数据。 它似乎也许只是每次覆盖同一行…

基本上，我在收件箱中有大约500封电子邮件，全部来自表单提交。 所有的数据格式都是这样的：

02sender_last_name：Jones 01sender_first_name：Bob

等等…我想把这些数据，并把它放入一个不错的Excel电子表格。 这是我现在的代码 – 但同样，它不是从多个电子邮件的数据到不同的行。 任何帮助新手？ 🙂

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:\test\test.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), "01sender_first_name:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("A" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "02sender_last_name: ") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("B" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "03contact_license_number: ") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("C" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "06contact_phone_area_code: ") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("D" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "07contact_phone_prefix: ") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("E" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "08contact_phone_number: ") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("F" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "city: ") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("G" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "email: ") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("H" & 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

我想你只需要改变这一点

 '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 

对此：

 'Process each selected record rCount = xlSheet.UsedRange.Rows.Count For Each olItem In Application.ActiveExplorer.Selection sText = olItem.Body vText = Split(sText, Chr(13)) 'Find the next empty line of the worksheet rCount = rCount + 1