Extract / Count Outlook Public Folder Emails based on Date Range in Excel

[Carrotkiller]

Hello All

I have put together some code in excel from various sources online(VBA X and others) to extract outlook emails from a series of public folders, its working fine but I would like to amend the code to only extract email based on a date range. At the moment its taking ages to run as its extracting all emails everytime I run it, I only need to run a weeks worth each time.

I will update the week commencing date(start date) on a summary sheet in excel and would like the macro to extract only emails in the folder based on that week(7days).

I'm not sure if I can do that using the method currently used.

Any help with this matter would be greatly appreciated!

Current working code below that is used for 1 of the folder counts.

Regards

Carrotkiller

Sub Inbox1Recieved()
    ' Declare Outlook app and folder object variables.
    Dim objOutlook As Object, objnSpace As Object
    Dim objfolder As Object ', CurrUser As String
    Dim EmailItemCount As Integer, I As Integer, EmailCount As Integer
    ' CurrUser As String
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")
    Set objfolder = objnSpace.Folders("Mailbox - #Shared Mailbox - PPNB").Folders("Inbox")
    'Verify existence of Inbox folder as direct subfolder of Personal Folders.
    On Error Resume Next
    ' Set objfolder = objnSpace.Folders("Mailbox - #Shared Mailbox - No Reply").Folders("Inbox")
    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "No such folder named Inbox.", 48, "Cannot continue"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Workbooks("NB Weekly Email Report").Sheets("Summary").Activate
    Range("B18").Value = Now()
    Workbooks("NB Weekly Email Report").Sheets("Pending").Activate
    ' the items.count command returns the count for the exisiting folder through which the code is looping across
    EmailItemCount = objfolder.Items.Count
    I = 0: EmailCount = 0
    ' read e-mail information
    While I < EmailItemCount
        I = I + 1
        If I Mod 50 = 0 Then Application.StatusBar = "Reading e-mail messages " & _
        Format(I / EmailItemCount, "0%") & "..."
        With objfolder.Items(I)
            EmailCount = EmailCount + 1
            Cells(EmailCount + 1, 1).Formula = .Subject
            Cells(EmailCount + 1, 2).Formula = Format(.ReceivedTime, "dd.mm.yyyy hh:mm:ss")
            Cells(EmailCount + 1, 3).Formula = .Attachments.Count
            Cells(EmailCount + 1, 4).Formula = Not .UnRead
            Cells(EmailCount + 1, 5).Formula = .SenderName
            Cells(EmailCount + 1, 6).Formula = .ReceivedTime
            Cells(EmailCount + 1, 7).Formula = .LastModificationTime
            Cells(EmailCount + 1, 8).Formula = .ReplyRecipientNames
            Cells(EmailCount + 1, 9).Formula = .SentOn
            Cells(EmailCount + 1, 10).Value = objfolder.Name
            ' Cells(EmailCount + 1, 5).Formula = .Body
            ' Cells(14).Value = objfolder.Name
        End With
    Wend
    Application.Calculation = xlCalculationAutomatic
    ' Set OLF = Nothing
    Set objfolder = Nothing
    Call Inbox2Replied1
End Sub