Цикл VBA для извлечения сводки электронных писем за последние 30 дней

Вам нужно просмотреть папку так же, как вы это делаете для папок и подпапок в проводнике Windows. Также я не вижу проверки даты?

Это то, что вы пытаетесь? Я прокомментировал код. Если у вас все еще есть вопрос, просто спросите.

PS: Весь процесс я разделил на две процедуры. Таким образом, легче понимать код и управлять им.

Option Explicit

Sub ExportEmailsToExcel()
    Dim outlookApp As Outlook.Application
    Dim outlookNamespace As Outlook.NameSpace
    Dim rootFolder As Outlook.MAPIFolder
    Dim xlApp As Object
    Dim xlWorkbook As Object
    Dim xlWorksheet As Object
    Dim row As Long: row = 2 '<~~ Use Long and not Integer
    
    Set outlookApp = New Outlook.Application
    Set outlookNamespace = outlookApp.GetNamespace("MAPI")
    Set rootFolder = outlookNamespace.Folders("[email protected]")

    '~~> Create a new Excel workbook
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlWorkbook = xlApp.Workbooks.Add
    Set xlWorksheet = xlWorkbook.Sheets(1)

    '~~> Set up the header row in Excel
    With xlWorksheet
        .Cells(1, 1).Value = "Date Received"
        .Cells(1, 2).Value = "From"
        .Cells(1, 3).Value = "From Email Address"
        .Cells(1, 4).Value = "Subject"
        .Cells(1, 5).Value = "Email Folder Location"
        .Cells(1, 6).Value = "Has Attachments"
    End With
    
    '~~> Loop through all folders and subfolders
    ProcessFolder rootFolder, xlWorksheet, row

    MsgBox "Export complete!", vbInformation
End Sub

'~~> Separate function for looping
Sub ProcessFolder(ByVal folder As Outlook.MAPIFolder, ByRef xlWorksheet As Object, ByRef row As Long)
    Dim subfolder As Outlook.MAPIFolder
    Dim item As Object
    Dim mailItem As Outlook.mailItem
    Dim dateLimit As Date
    
    '~~> Check for last 30 days
    dateLimit = DateAdd("d", -30, Now)
    
    '~~> Loop
    For Each item In folder.Items
        If TypeName(item) = "MailItem" Then
            Set mailItem = item
            If mailItem.ReceivedTime >= dateLimit Then
                xlWorksheet.Cells(row, 1).Value = mailItem.ReceivedTime
                xlWorksheet.Cells(row, 2).Value = mailItem.SenderName
                xlWorksheet.Cells(row, 3).Value = mailItem.SenderEmailAddress
                xlWorksheet.Cells(row, 4).Value = mailItem.Subject
                xlWorksheet.Cells(row, 5).Value = folder.FolderPath
                xlWorksheet.Cells(row, 6).Value = IIf(mailItem.Attachments.Count > 0, "True", "False")
                row = row + 1
            End If
        End If
    Next item
    
    '~~> Loop through sub folders if any
    For Each subfolder In folder.Folders
        ProcessFolder subfolder, xlWorksheet, row
    Next subfolder
End Sub