決まった件名のメッセージを受信したら、データを Excel ファイルに保存するマクロ

コメントにて以下のご要望をいただきました。

---

こんにちわ。
  指定のタイトルのメールを受信した場合に、本文の一部をエクセルにコピーするマクロはどのように作成するか、教えていただけないでしょうか。
  例えば
  タイトル
  ・タイトル
本文
・番号:〇〇○
・氏名:△△△
・住所:◻︎◽︎◻︎
・生年月日:××
・依頼内容:☆☆☆
というメールを受け取った際に、番号欄の〇〇○、氏名欄の△△△、依頼内容の☆☆☆のみを指定のエクセルデータに一覧として出力をしたいです。
エクセルの1行目には番号、氏名、依頼内容など項目名は事前にある状態です。
  複数のメールの内容を一つのエクセルに一覧として入力をしたいです。
  以上、よろしくお願いします。

---

以前、決まった件名のメッセージを受信したら、データを CSV ファイルに保存するマクロとして似たようなマクロを公開していますが、こちらのマクロでテキストファイルに書き出している処理を Excel ファイルへの書き出しに変更することでご要望は実現できます。
マクロは以下のようになります。


' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     SaveToExcel EntryIDCollection
End Sub
'
Private Sub SaveToExcel(ByVal EntryIDCollection As String)
     Const AUTO_SAVE_TITLE = "タイトル" ' 自動処理するメールの件名
     Const EXCEL_FILE = "c:\temp\request.xlsx" ' 保存する Excel ファイルの名前
     Dim i As Integer
     Dim myMsg
     ' メッセージの取得
     Set myMsg = Session.GetItemFromID(EntryIDCollection)
     ' 指定の件名のメールのみ処理を実行
     If myMsg.Subject = AUTO_SAVE_TITLE Then
         Dim objBook
         Dim objSheet
         Dim r As Integer
         Dim strCode
         Dim strName
         Dim strQuantity
         ' Excel ファイルを開く
         Set objBook = GetObject(EXCEL_FILE)
         objBook.windows(1).Activate
         Set objSheet = objBook.sheets(1)
         ' 1 行目はタイトルとして使用し、2 行目からデータ
         r = 2
         ' データがない行まで移動
         While objSheet.Cells(r, 1) <> ""
             r = r + 1
         Wend
         ' 本文から取り出したデータを Excel ファイルに転記
         With objSheet
             .Cells(r, 1) = GetText("番号:", myMsg.Body)
             .Cells(r, 2) = GetText("氏名:", myMsg.Body)
             .Cells(r, 3) = GetText("依頼内容:", myMsg.Body)
         End With
         ' Excel ファイルを閉じる
         objBook.Close True
     End If
End Sub
' 本文からデータを取得する関数
Private Function GetText(strName As String, strBody As String) As String
     Dim ls As Long
     Dim le As Long
     ls = InStr(strBody, strName) ' 指定されたフィールド名を検索
     If ls > 0 Then
         ls = ls + Len(strName) ' フィールド名の次の文字から
         le = InStr(ls, strBody, vbCrLf) ' 改行コードまでを取得
         GetText = Trim(Mid(strBody, ls, le - ls)) ' 前後の空白を削除
     Else
         GetText = ""
     End If
End Function


マクロの登録方法やメニューへの追加について