前の月に受信したメールのうち、特定のキーワードを含むメールをサブフォルダーも含めてカウントするマクロ

前の月に受信したメールのうち、特定のキーワードを含むメールをカウントするマクロのコメントにて以下のご要望をいただきました。

---

コメント失礼します。
このマクロを試させて頂き、動作を確認させて頂きました。
これは既定フォルダのみ検索したカウント数であると思います。
そうであれば1点機能を追加したいのですが、作り方がわからずご教示頂けましたら幸いです。
＜内容＞
受信トレイ内にあるすべてのサブフォルダにアクセスし、キーワードカウントをしたいです。
Outlook2013を使用しています。

---

すべてのサブフォルダーについて処理をする場合は、再帰という方法を使用します。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub FindMailByKeywordLastMonthRecursive()
    On Error Resume Next
    ' 検索するキーワードを指定
    Const SEARCH_KEY = "test"
    ' レポートを作成するファイルのフルパスを指定
    Const REPORT_FILE = "c:\temp\report.txt"
    Dim dtStart As Date
    Dim dtEnd As Date
    Dim strFilter As String
    Dim cntItems As Integer
    Dim strReport As String
    ' 前月を表す日付範囲を算出
    dtEnd = Year(Now) & "/" & Month(Now) & "/1"
    dtStart = DateAdd("m", -1, dtEnd)
    ' 日付範囲でフィルタリング
    strFilter = "[受信日時] >= #" & dtStart & "# AND [受信日時] <  #" & dtEnd & "#"
    cntItems = 0
    ' 検索実行
    strReport = FindMailRecursive(Session.GetDefaultFolder(olFolderInbox), strFilter, SEARCH_KEY, cntItems)
    ' レポート作成
    Open REPORT_FILE For Output As #1
    Print #1, SEARCH_KEY & "を含むメールの件数:", cntItems
    Print #1, strReport
    Close #1
    ' レポートをメモ帳で表示
    Shell "notepad.exe " & REPORT_FILE
End Sub
'
Private Function FindMailRecursive(fldRoot As Folder, strFilter As String, strKeyword As String, ByRef cntItems As Integer) As String
    On Error Resume Next
    Dim strReport As String
    Dim colItems As Items
    Dim objItem As Object
    Dim fldSub As Folder
    Debug.Print fldRoot.FolderPath
    ' フィルタ文字列で検索
    Set colItems = fldRoot.Items
    colItems.Restrict strFilter
    strReport = ""
    ' フィルタリングしたメールを確認
    For Each objItem In colItems
        ' 件名にキーワードを含む場合はカウンタとレポート追加
        If objItem Is MailItem Then
            If InStr(1, objItem.Subject, strKeyword, vbTextCompare) > 0 Then
                cntItems = cntItems + 1
                strReport = strReport & objItem.ReceivedTime & vbTab & objItem.Subject & vbCrLf
            End If
        End If
    Next
    ' レポートが存在する場合は先頭にフォルダーパスを追加
    If strReport <> "" Then
        strReport = "フォルダー:" & fldRoot.FolderPath & vbCrLf & strReport
    End If
    ' サブフォルダーについて再帰的に実行
    For Each fldSub In fldRoot.Folders
        strReport = strReport & FindMailRecursive(fldSub, strFilter, strKeyword, cntItems)
    Next
    '
    FindMailRecursive = strReport
End Function

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