メールメッセージを抽出してスプレッドシートに値を入力する方法

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

です。あなたは

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

ループに

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

に

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

を変更した場合、それはあなたの問題を修正する必要があります。

編集：申し訳ありません、findwindow。質問の下にコメントスレッドは表示されませんでした。私はちょうどその質問にまだ答えがないことを見た。