如何提取电子邮件和填充电子表格的值
我有一个macros，它读取收件箱中的未读消息，并使用“：”分隔符从消息中提取数据。 在循环中，我想能够加载新的Excel电子表格与消息的值。
我能够select第一个单元格并保存数据，但是它正在被写入。 每次在循环中我想要数据到列中的下一个单元格是空的，而不是覆盖同一个单元格。
这是我的代码到目前为止…
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)
至
Range("A" & LR + 1).Value = Result(k)
在你的
For k = LBound(Prop) To UBound(Prop)
循环，这应该纠正你的问题。
编辑：对不起，findwindow。 我没有看到问题下面的评论线程。 我刚才看到这个问题还没有答案。