Question

我有一个宏来读取收件箱中的未读邮件，并使用分隔符“：”从邮件中提取数据。在循环中，我希望能够使用消息中的值加载新的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

Answer 1

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

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

到

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

中的

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

循环，这应该可以纠正你的问题。

编辑：抱歉，发现窗口。我没有在问题下面看到评论帖。我刚看到这个问题还没有答案。

如何使用值提取电子邮件和填充电子表格

1 个答案: