Outlook VBAで受信メールのサブフォルダ内のメールを抽出してExcelに出力させる方法

Sub ExportSubfolderEmailsToExcel()
    Dim olApp As Object
    Dim olNamespace As Object
    Dim olFolder As Object
    Dim olSubfolder As Object
    Dim olMailItem As Object
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlWS As Object
    Dim iRow As Integer
    
    ' Outlookアプリケーションを取得
    Set olApp = CreateObject("Outlook.Application")
    ' Outlookの名前空間を取得
    Set olNamespace = olApp.GetNamespace("MAPI")
    
    ' メールを取得する受信トレイのサブフォルダを指定
    Set olFolder = olNamespace.GetDefaultFolder(6) ' 6は受信トレイを表す
    
    ' サブフォルダの名前を指定（例: "サブフォルダ名"）
    Set olSubfolder = olFolder.Folders("サブフォルダ名")
    
    ' Excelアプリケーションを起動
    Set xlApp = CreateObject("Excel.Application")
    ' 新しいワークブックを作成
    Set xlWB = xlApp.Workbooks.Add
    ' ワークシートを選択
    Set xlWS = xlWB.Sheets(1)
    
    ' エクセルのヘッダー行を追加
    xlWS.Cells(1, 1).Value = "受信日時"
    xlWS.Cells(1, 2).Value = "送信者"
    xlWS.Cells(1, 3).Value = "件名"
    xlWS.Cells(1, 4).Value = "本文"
    
    ' 行カウンタ
    iRow = 2
    
    ' サブフォルダ内のメールをループ処理
    For Each olMailItem In olSubfolder.Items
        If olMailItem.Class = 43 Then ' メールアイテムのクラスは43（olMail）です
            xlWS.Cells(iRow, 1).Value = olMailItem.ReceivedTime
            xlWS.Cells(iRow, 2).Value = olMailItem.SenderName
            xlWS.Cells(iRow, 3).Value = olMailItem.Subject
            xlWS.Cells(iRow, 4).Value = olMailItem.Body
            iRow = iRow + 1
        End If
    Next olMailItem
    
    ' Excelファイルを保存（任意）
    ' xlWB.SaveAs "C:\Path\To\Your\Excel\File.xlsx"
    
    ' メモリを解放してOutlookとExcelを閉じる
    Set olApp = Nothing
    Set xlApp = Nothing
End Sub