Excel 如何提取电子邮件并用值填充电子表格

我有一个宏，它读取收件箱中的未读邮件，并用分隔符“：”从邮件中提取数据。在循环中，我希望能够使用消息中的值加载新的excel电子表格

我能够选择第一个单元格并保存数据，但它正在被重写。每次在循环中，我都希望数据转到列中空的下一个单元格，而不是覆盖同一个单元格

这是我到目前为止的代码

Public Sub Application_NewMail()

Dim newbk As Workbook
Set newbk = Workbooks.Add
newbk.SaveAs "C:\Users\RickG\Desktop\test2.xlsx"  'other parameters can  be set here if required
' perform operations on newbk
newbk.Close savechanges:=True

Dim ns As Outlook.NameSpace
Dim InBoxFolder As MAPIFolder
Dim InBoxItem As Object 'MailItem
Dim Contents As String, Delimiter As String
Dim Prop, Result
Dim i As Long, j As Long, k As Long

'Setup an array with all properties that can be found in the mail
Prop = Array("Name", "Email", "Phone", "Customer Type", _
"Message")
'The delimiter after the property
Delimiter = ":"

 Set ns = Session.Application.GetNamespace("MAPI")


'Access the inbox folder
Set InBoxFolder = ns.GetDefaultFolder(olFolderInbox)

Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim ws As Worksheet

Set xlApp = New Excel.Application
With xlApp
    .Visible = False
    Set xlWB = .Workbooks.Open("C:\Users\RickG\Desktop\test2.xlsx", , False)
    Set ws = .Worksheets("Sheet1")
 End With
Dim LR As Long

For Each InBoxItem In InBoxFolder.Items

'Only process mails
If Not TypeOf InBoxItem Is MailItem Then GoTo SkipItem
'Skip wrong subjects
If InStr(1, InBoxItem.Subject, "FW: New Lead - Consumer - Help with Medical Bills", vbTextCompare) = 0 Then GoTo SkipItem
'Already processed?
If Not InBoxItem.UnRead Then GoTo SkipItem
'Mark as read
InBoxItem.UnRead = False
'Get the body
Contents = InBoxItem.Body
'Create space for the result
ReDim Result(LBound(Prop) To UBound(Prop)) As String
'Search each property
i = 1

For k = LBound(Prop) To UBound(Prop)

  'Find the property (after the last position)
  i = InStr(i, Contents, Prop(k), vbTextCompare)
  If i = 0 Then GoTo NextProp
  'Find the delimiter after the property
  i = InStr(i, Contents, Delimiter)
  If i = 0 Then GoTo NextProp
  'Find the end of this line
  j = InStr(i, Contents, vbCr)
  If j = 0 Then GoTo NextProp
  'Store the related part
  Result(k) = Trim$(Mid$(Contents, i + Len(Delimiter), j - i - Len(Delimiter)))
  'for every row, find the first blank cell and select it
'MsgBox Result(k)
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A" & LR).Value = Result(k)
  'Update the position
  i = j

NextProp:
Next

xlApp.DisplayAlerts = False
xlWB.SaveAs ("C:\Users\RickG\Desktop\test2.xlsx")
xlWB.Close
xlApp.Quit

If MsgBox(Join(Result, vbCrLf), vbOKCancel, "Auto Check In") = vbCancel Then Exit Sub
SkipItem:
Next

End Sub

---

你没有正确地跟踪你的循环。如果你改变

Range("A" & LR).Value = Result(k)

到

在你的

For k = LBound(Prop) To UBound(Prop)

循环，这将纠正您的问题

编辑：对不起，芬德温多。我没有看到问题下方的评论帖子。我刚才看到这个问题还没有答案。

将

Range（“A”&LR）。Value=Result（k）

更改为

Range（“A”&LR+1）。Value=Result（k）

For k = LBound(Prop) To UBound(Prop)