Extract email attachments from date received

Question

I have code to extract all email attachments from specific email folder.

I want to change to extract email attachments starting from a date which I enter in a dialog box. I want to extract email attachments from emails received in the last seven days.

Sub Extract_emails()
    Dim OlApp As Object
    Dim OlMail As Object
    Dim OlItems As Object
    Dim Olfolder As Object
    Dim J As Integer
    Dim strFolder As String

    Set OlApp = GetObject(, "Outlook.Application")        
    If Err.Number = 429 Then
        Set OlApp = CreateObject("Outlook.Application")   
    End If

    strFolder = ThisWorkbook.Path & "\Extract"            
    Set Olfolder = OlApp.getnamespace("MAPI").Folders("MyEmailAddress").Folders("Inbox")
    Set OlItems = Olfolder.Items

    For Each OlMail In OlItems
    If OlMail.Attachments.Count > 0 Then
        For J = 1 To OlMail.Attachments.Count
        OlMail.Attachments.Item(J).SaveAsFile strFolder & "\" & OlMail.Attachments.Item(J).Filename
        Next J
    
    End If
    
    Set OlApp = Nothing
    Set OlMail = Nothing
    Set OlItems = Nothing
    Set Olfolder = Nothing

    Next

    MsgBox ("Done")
End Sub

I need to extract only xlsx attachments (vendor sends Excel and pdf documents) and to save them in folder. After I need to open saved Excel file and to copy data in base and to close saved xlsx. I don't know name of xlsx file (usually it is our company name and some numbers) but every report has sheets "shipped" from which I copy data in base. No one reads these emails that's why I tried with unread emails.

Code which works with F8 but not with F5.

Set OlApp = GetObject(, "Outlook.Application")

If Err.Number = 429 Then
    Set OlApp = CreateObject("Outlook.Application")
End If

strFolder = ThisWorkbook.Path & "\Extract"
Set Olfolder = OlApp.getnamespace("MAPI").Folders("Freight.Invoice@omega.com").Folders("Inbox")
Set OlItems = Olfolder.Items

For Each OlMail In OlItems
    
    If OlMail.UnRead = True Then

        If OlMail.Attachments.Count > 0 Then
        
        For J = 1 To OlMail.Attachments.Count
            FilePath = strFolder & "\" & OlMail.Attachments.Item(J).FileName
            OlMail.Attachments.Item(J).SaveAsFile FilePath
            If Right(FilePath, 4) = "xlsx" Then
            
                runit FilePath
                For I = 1 To Worksheets.Count
                    If Worksheets(I).Name = "Shipped" Then
                        Worksheets("Shipped").Activate
                        Set wsCopy = Worksheets("Shipped")
                        Set wsDest = Workbooks("Extract 
 emails.xlsm").Worksheets("DATA")
                        lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, 
 "B").End(xlUp).Row
                        lDestLastRow = wsDest.Cells(wsDest.Rows.Count, 
"B").End(xlUp).Offset(1).Row
                        wsCopy.Range("B4:K" & lCopyLastRow).Copy _
                        wsDest.Range("B" & lDestLastRow)
                        
                        Worksheets("Shipped").Activate
                        ActiveWorkbook.Close savechanges:=False
                        
                        
                    End If
                Next
                    
            End If
        
            Next J

        End If
    
    End If

Next

For Each OlMail In OlItems
    
    If OlMail.UnRead = True Then
        OlMail.UnRead = False
        DoEvents
        OlMail.Save
    End If

    Set OlApp = Nothing
    Set OlMail = Nothing
    Set OlItems = Nothing
    Set Olfolder = Nothing

Next


MsgBox ("Done")


End Sub 


Sub runit(FilePath As String)

Dim Shex As Object
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

Set Shex = CreateObject("Shell.Application")
Shex.Open (FilePath)

End Sub

Answer 1

I have finished testing the system I proposed in my original answer. It is not exactly the same, for reasons I will explain later, but it matches in all important details. I am posting it as new answer so there is no confusion.

To test it, I created some workbooks which I named Test1, Test2, Test3 and so on. Within each workbook I created a worksheet “Shipped”. Each of these worksheets had a different number of rows and columns. Each cell contained “T-R-C” where T was the test number, R was the row and C was the column. These values made it very easy to check that data was copied correctly from the attachments to the consolidated worksheet. After deleting most of the rows so the structure was visible, the result of consolidation was:

You can see that my code can combine all the rows and all the columns from as many emails as required. My emails are not a week apart but that is not important.

My recommendation is that you try my macro as it is. You can then discuss the appearance with your colleagues, and we can then discuss how to change my macro to match your exact requirements.

Create a new disc folder and within it create two new workbooks: one ordinary (xlsx) and one macro-enabled (xlsm).

Name the ordinary workbook “Consolidated Data.xlsx”. Within it, rename the default worksheet as “Shipped”.

The name of the macro-enabled workbook is unimportant as is the name of the worksheet. Within the VBA Editor, create three modules and name then "LibExcel", "LibOutlook" and "ModConsolidate". Naming modules is not essential but dividing macros up by purpose and naming modules for those purposes makes life much easier.

I will tell you to move the code below to one of these three modules.

Module "ModConsolidate" is for code I have written specifically for your requirement. Module "LibExcel" is for code from my library of Excel related routines. Module "LibOutlook" is for code from my library of Outlook related routines.

When I end a project, I look through it to see if there is any code I might wish to use again. If there is, I extract it and save it in "PERSONAL.XLSB" which I use as my library. Any macro saved in this workbook is available to all other workbooks. Don’t bother today but when you have some spare time look up how to create "PERSONAL.XLSB". When you have created it, move modules "LibExcel" and "LibOutlook" to it. In "LibExcel", I have routines to find the last used row and column of a worksheet and to check is a named worksheet exists. In "LibOutlook" I have routines for opening and closing an instance of Outlook from Excel.

When I start a project, I look through my library for routines that might be appropriate. If necessary, a routine will be enhanced to provide functionality that I had not needed before. The result is I have a library of useful functions that get more powerful, and larger, as I complete each project.

I said I would have version numbers on the workbook I created for you. Unfortunately, the macros that handle this and related functionality are too large to post to Stack Overflow.

This code should go in LibExcel:

' Routines useful with Excel

Option Explicit
Public Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
                          ByRef ColLast As Long)

  ' Sets RowLast and ColLast to the last row and column with a value
  ' in worksheet Wsht

  ' The motivation for coding this routine was the discovery that Find by
  ' previous row found a cell formatted as Merge and Center but Find by
  ' previous column did not.
  ' I had known the Find would miss merged cells but this was new to me.

  '   Dec16  Coded
  ' 31Dec16  Corrected handling of UserRange
  ' 15Feb17  SpecialCells was giving a higher row number than Find for
  '          no reason I could determine.  Added code to check for a
  '          value on rows and columns above those returned by Find
  ' 25Jun17  Found column with value about that found by Find

  Dim ColCrnt As Long
  Dim ColLastFind As Long
  Dim ColLastOther As Long
  Dim ColLastTemp As Long
  Dim ColLeft As Long
  Dim ColRight As Long
  Dim Rng As Range
  Dim RowIncludesMerged As Boolean
  Dim RowBot As Long
  Dim RowCrnt As Long
  Dim RowLastFind As Long
  Dim RowLastOther As Long
  Dim RowLastTemp As Long
  Dim RowTop As Long

  With Wsht

    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
    If Rng Is Nothing Then
      RowLastFind = 0
      ColLastFind = 0
    Else
      RowLastFind = Rng.Row
      ColLastFind = Rng.Column
    End If

    Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
    If Rng Is Nothing Then
    Else
      If RowLastFind < Rng.Row Then
        RowLastFind = Rng.Row
      End If
      If ColLastFind < Rng.Column Then
        ColLastFind = Rng.Column
      End If
    End If

    Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
    If Rng Is Nothing Then
      RowLastOther = 0
      ColLastOther = 0
    Else
      RowLastOther = Rng.Row
      ColLastOther = Rng.Column
    End If

    Set Rng = .UsedRange
    If Rng Is Nothing Then
    Else
      If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
        RowLastOther = Rng.Row + Rng.Rows.Count - 1
      End If
      If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
        ColLastOther = Rng.Column + Rng.Columns.Count - 1
      End If
    End If

    If RowLastFind < RowLastOther Then
      ' Higher row found by SpecialCells or UserRange
      Do While RowLastOther > RowLastFind
        ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
        If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
          Debug.Assert False
          ' Is this possible
          ' Row after RowLastFind has value
          RowLastFind = RowLastOther
          Exit Do
        End If
        RowLastOther = RowLastOther - 1
      Loop
    ElseIf RowLastFind > RowLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    RowLast = RowLastFind

    If ColLastFind < ColLastOther Then
      ' Higher column found by SpecialCells or UserRange
      Do While ColLastOther > ColLastFind
        RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
        If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
          'Debug.Assert False
          ' Column after ColLastFind has value
          ' Possible causes:
          '   * Find does not recognise merged cells
          '   ' Find does not examine hidden cells
          ColLastFind = ColLastOther
          Exit Do
        End If
        ColLastOther = ColLastOther - 1
      Loop
    ElseIf ColLastFind > ColLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    ColLast = ColLastFind

  End With

End Sub
Public Function WshtExists(ByRef Wbk As Workbook, ByVal WshtName As String) As Boolean

  ' Returns True if Worksheet WshtName exists within
  '  * if Wbk Is Nothing the workbook containing the macros
  '  * else workbook Wbk

  ' 21Aug16  Coded by Tony Dallimore
  ' 14Feb17  Coded alternative routine that cycled through the existing worksheets
  '          matching their names against WshtName to check if use of "On Error Resume Next"
  '          was the faster option. I needed to call the routines 6,000,000 times each to
  '          get an adequate duration for comparison. This version took 33 seconds while
  '          the alternative took 75 seconds.
  ' 21Feb20  Added "As Boolean" to declaration. Do not understand how routine worked
  '          without it.

  Dim WbkLocal As Workbook
  Dim Wsht As Worksheet

  If Wbk Is Nothing Then
    Set WbkLocal = ThisWorkbook
  Else
    Set WbkLocal = Wbk
  End If

  Err.Clear
  On Error Resume Next
  Set Wsht = WbkLocal.Worksheets(WshtName)
  On Error GoTo 0
  If Wsht Is Nothing Then
    WshtExists = False
  Else
    WshtExists = True
  End If

End Function

This code should go in LibOutlook

' Routines useful with Outlook.

Option Explicit
Public Sub OutAppClose(ByRef OutApp As Outlook.Application, ByVal Created As Boolean)

  ' If Created is True, quit the current instance if Outlook.

  If Created Then
    OutApp.Quit
  End If

  Set OutApp = Nothing

End Sub
Public Function OutAppGetCreate(ByRef Created As Boolean) As Outlook.Application

  ' Return a reference to the Outlook Application.
  ' Set Created to True if the reference is to a new application and to
  ' False if the reference is to an existing application.

  ' If Nothing is returned, the routine has been unable to get or create a reference.

  ' Only one instance of Outlook can be running.  CreateObject("Outlook.Application")
  ' will return a reference to the existing instance if one is already running or
  ' will start a new instance if one is not running.  The disadvantage of using
  ' CreateObject, is the caller does not know if Outlook was running so does not know
  ' whether or not to quit Outlook when it has finished using Outlook.  By setting
  ' Created, this routine allows the caller to only quit if this is appropriate.

  Set OutAppGetCreate = Nothing
  On Error Resume Next
  Set OutAppGetCreate = GetObject(, "Outlook.Application")
  On Error GoTo 0
  If OutAppGetCreate Is Nothing Then
    On Error Resume Next
    Set OutAppGetCreate = CreateObject("Outlook.Application")
    On Error GoTo 0
    If OutAppGetCreate Is Nothing Then
      Call MsgBox("I am unable to access Outlook", vbOKOnly)
      Exit Function
    End If
    Created = True
  Else
    Created = False
  End If

End Function

This code should go in ModConsolidate:

Option Explicit

  ' * Need reference to "Microsoft Outlook nn.n Object Library"
  '   where nn.n depends on the version of Office being used.
  ' * Needs reference to "Microsoft Scripting Runtime"

  Const HeaderForData As String = "Data from email received"
  Const WbkConName As String = "Consolidated Data.xlsx"
  Const WshtName As String = "Shipped"  ' Also used for name of workbooks
Sub ConsolidateDataFromShippedWshts() ()

  ' Outlook used "ol" as a prefix for its constants. I do not use the same
  ' prefix to avoid a clash.
  Dim OutApp As Outlook.Application
  Dim OutAppCreated As Boolean

  Dim ColConLast As Long             ' Last column of worksheet "Shipped" in consolidated workbook
  Dim ColSrcLast As Long             ' Last column of worksheet "Shipped" in source workbook
  Dim DateLatestExisting As Date     ' Date of last block of data in consolidated workbook
  Dim DateStr As String              ' Date extracted from header row
  Dim FldrShipped As Outlook.Folder  ' Outlook Folder containing source emails
  Dim InxA As Long                   ' Index into attachments
  Dim InxI As Long                   ' Index into mail items
  Dim InxW As Long                   ' Into into WbkSrcNames
  Dim ItemsShipped As Items          ' Items in source folder
  Dim Path As String                 ' Disc folder containing workbooks
  Dim Rng As Range                   ' Various uses
  Dim RowConCrnt As Long             ' Current row of worksheet "Shipped" in consolidated workbook
  Dim RowConLast As Long             ' Last row of worksheet "Shipped" in consolidated workbook
  Dim RowSrcLast As Long             ' Last row of worksheet "Shipped" in source workbook
  Dim WbkCon As Workbook             ' Consolidated workbook
  Dim WbkMacros As Workbook          ' This workbook
  Dim WbkSrc As Workbook             ' Workbook extracted from email
  Dim WbkSrcName As String           ' Name of workbook extracted from email
  Dim WbkSrcNameDates As Collection  ' Collection of the names and dates of workbooks extracted from emails
  Dim WshtCon As Worksheet           ' Worksheet "Shipped" in consolidated workbook
  Dim WshtSrc As Worksheet           ' Worksheet "Shipped" in source workbook

  Application.ScreenUpdating = False

  Set WbkMacros = ThisWorkbook

  Path = WbkMacros.Path

  ' ### Change if you want a different name for consolidated workbook
  Set WbkCon = Workbooks.Open(Path & "\" & WbkConName)
  Set WshtCon = WbkCon.Worksheets(WshtName)

  ' Find last used row of consolidated worksheet
  Call FindLastRowCol(WshtCon, RowConLast, ColConLast)

  If RowConLast = 0 Then
    ' No data added yet
    DateLatestExisting = 0
  Else
    ' Search up for header for last block of data added
    With WshtCon
      Set Rng = .Columns(1).Find( _
                      What:=HeaderForData, After:=.Cells(RowConLast + 1, 1), _
                      LookIn:=xlValues, LookAt:=xlPart, _
                      SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                      MatchCase:=False, SearchFormat:=False)
      If Rng Is Nothing Then
        Debug.Assert False
        ' It should not be possible to be here.  Either the worksheet is empty
        ' and RowColLast = 0 or one or more blocks of data, each with a header,
        ' have been added.  It appears the worksheet is not as it should be.
        DateLatestExisting = 0
      Else
        DateStr = Mid$(.Cells(Rng.Row, 1).Value, Len(HeaderForData) + 2)
        If IsDate(DateStr) Then
          DateLatestExisting = DateValue(DateStr) + TimeValue(DateStr)
        Else
          Debug.Assert False
          ' It should not be possible to be here.  The text after HeaderForData
          ' should be a valid date. It appears the worksheet is not as it should be.
          DateLatestExisting = 0
        End If
      End If

    End With
  End If

  Set OutApp = OutAppGetCreate(OutAppCreated)

  If OutApp Is Nothing Then
    ' OutAppGetCreated() failed.  The user has already been told.
    Exit Sub
  End If

  ' ### Change to access folder where you store these emails
  Set FldrShipped = OutApp.Session.Folders("MyName@MyIsp").Folders("Test")

  ' Create list of items in folder sorted by ReceivedTime
  Set ItemsShipped = FldrShipped.Items
  ItemsShipped.Sort "ReceivedTime", True

  Set WbkSrcNameDates = New Collection

  ' Read items, newest first, until reach an item at or before DateLatestExisting
  ' Save xlsx attachment, if any, and record names in WbkSrcNames
  For InxI = 1 To ItemsShipped.Count
    If TypeName(ItemsShipped(InxI)) = "MailItem" Then
      If ItemsShipped(InxI).ReceivedTime <= DateLatestExisting Then
        ' No more unprocessed emails
        Exit For
      End If
      ' Save Xlsx attachment, if any
      For InxA = 1 To ItemsShipped(InxI).Attachments.Count
        If LCase(Right$(ItemsShipped(InxI).Attachments(InxA).FileName, 5)) = ".xlsx" Then
          ' Have found required attachment. Save with name based on date received
          WbkSrcName = WshtName & " " & Format(ItemsShipped(InxI).ReceivedTime, "yymmdd hhmmss") & ".xlsx"
          ItemsShipped(InxI).Attachments(InxA).SaveAsFile Path & "\" & WbkSrcName
          WbkSrcNameDates.Add VBA.Array(WbkSrcName, ItemsShipped(InxI).ReceivedTime)
          Exit For
        End If
      Next
    End If
  Next

  Call OutAppClose(OutApp, OutAppCreated)

  If WbkSrcNameDates.Count = 0 Then
    ' No new emails with xlsx attachments
    WbkCon.Close SaveChanges:=False
    Call MsgBox("No new emails containing an xlsx attachment", vbOKOnly)
    Set WshtCon = Nothing
    Set WbkCon = Nothing
    Set WbkMacros = Nothing
    Exit Sub
  End If

  ' WbkSrcNameDates contains the names and received dates of the new workbooks
  ' with the newest first.
  ' Extract names in reverse order (oldest first) and add contents of worksheet
  ' "Shipped" to bottom of worksheet "Shipped" of consolidated workbook

  For InxW = WbkSrcNameDates.Count To 1 Step -1
    Set WbkSrc = Workbooks.Open(Path & "\" & WbkSrcNameDates(InxW)(0))
    If WshtExists(WbkSrc, WshtName) Then
      ' Worksheet "Shipped" exists
      Set WshtSrc = WbkSrc.Worksheets(WshtName)
      Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)
      RowConCrnt = RowConLast + 1   ' Advance to first free row
      With WshtCon.Cells(RowConCrnt, 1)
        .Value = HeaderForData & " " & Format(WbkSrcNameDates(InxW)(1), "d-mmm-yy h:mm:ss")
        .Font.Bold = True
      End With
      RowConCrnt = RowConCrnt + 1
      With WshtSrc
        .Range(.Cells(1, 1), .Cells(RowSrcLast, ColSrcLast)).Copy _
                      Destination:=WshtCon.Cells(RowConCrnt, 1)
      End With
      RowConLast = RowConCrnt + RowSrcLast - 1
    End If

    WbkSrc.Close SaveChanges:=False
  Next

  ' Position cursor to header for latest data
  Application.ScreenUpdating = True
  WshtCon.Activate
  WshtCon.Cells(RowConLast - RowSrcLast, 1).Select
  Application.Goto ActiveCell, True
  WbkCon.Close SaveChanges:=True

  Set WshtCon = Nothing
  Set WbkCon = Nothing
  Set WbkMacros = Nothing

End Sub

At the top of ModConsolidate, it says it needs references to "Microsoft Outlook nn.n Object Library", where nn.n depends on the version of Office being used, and "Microsoft Scripting Runtime". If you are unsure what that means, ask and I will add an explanation.

Line 173 of ModConsolidate is Set FldrShipped = OutApp.Session.Folders("MyName@MyIsp").Folders("Test"). This references the Outlook folder in which I placed the test emails. Replace my Outlook folder with the one holding these emails on your system. Place as many of these emails as you have in that folder.

Run macro ConsolidateDataFromShippedWshts(). This macro will:

• Open workbook “Consolidated Data.xlsx”
• Check worksheet “Shipped” and find that it is empty.
• Open Outlook if not already open.
• Access the Outlook folder and extract the workbook from every email because worksheet “Shipped” is empty. Workbooks will be saved with the name “Shipped yymmdd hhmmss.xlsx”. If worksheet “Shipped” had not been empty, it would only have extracted workbooks from the newer emails.
• Close Outlook if it was not open.
• Open each of the new workbooks in turn and add the contents of their worksheet “Shipped” to worksheet “Shipped” within “Consolidated Data.xlsx”.

I have tested macro ConsolidateDataFromShippedWshts() thoroughly but only with my fake workbooks and emails. It should work properly unless I have misunderstood the nature of your workbooks and emails. If something goes wrong, describe the problem to me and I will try to diagnose the cause.

If everything works as expected. Review “Consolidated Data.xlsx” and discuss it with your colleagues. While you are doing that, I will start adding more information about my macro to this answer.

Answer 2

This is a tutorial rather than a direct answer to your question. I cover everything you need to know. I believe you will find this approach more useful than “a run this code and it will work” answer. I hope I have explained everything adequately. Come back with questions if necessary.

You need to compare an email’s ReceivedTime against the oldest required date. You say you intend to enter the oldest required date and you also say you want the last seven days. There may be an alternative. Type the following commands (except the comments) in you Immediate Window.

? now()                                The current date and time
? datevalue(now())                     The current date      
? dateadd("d",-7,now())                Seven days before now
? dateadd("d",-7,datevalue(now()))     Seven days ago
? dateadd("ww",-1,datevalue(now()))    One week ago

Do any of these expressions give you the date you want? In DateAdd, “d” and “ww” are intervals with “d” meaning days and “ww” meaning weeks. There are other values such as “w” meaning weekdays. Experiment if one of these expressions gives you almost what you want.

Other possibilities include setting a category or a custom property when the attachments are saved.

If you have not done so already, open your workbook and the VBA Editor. Click [Tools] then [References…]. Is “Microsoft Outlook nn.n Object Library” near the top of the list and ticked? Note: “nn.n” depends on the version of Office you are using. If this library is not listed and ticked, scroll down until you find it and click the little box to tick it. This gives your workbook access to Outlook data items so you do not have to specify so many Objects.

Now create a new module and copy the code below to it. If you run macro Demo(), you will get output like this:

Oldest additions to Inbox
  [14/12/2019 18:21:21]  [28/12/2019 05:05:00]  [08/01/2020 18:37:09]  [28/03/2019 16:16:12]  [21/03/2019 14:00:08]
  [14/06/2018 21:02:34]  [03/02/2020 09:29:38]  [06/03/2020 17:03:50]  [11/03/2020 13:43:33]  [12/03/2020 00:07:53]
  [13/03/2020 08:46:58]  [13/03/2020 17:31:23]  [14/03/2020 03:42:53]  [14/03/2020 08:07:35]  [14/03/2020 08:58:11]
  [15/03/2020 19:43:16]  [16/03/2020 16:48:40]  [16/03/2020 20:39:58]  [17/03/2020 11:14:29]  [18/03/2020 01:43:37]

Newest additions to Inbox
  [18/03/2020 01:43:37]  [17/03/2020 11:14:29]  [16/03/2020 20:39:58]  [16/03/2020 16:48:40]  [15/03/2020 19:43:16]
  [14/03/2020 08:58:11]  [14/03/2020 08:07:35]  [14/03/2020 03:42:53]  [13/03/2020 17:31:23]  [13/03/2020 08:46:58]
  [12/03/2020 00:07:53]  [11/03/2020 13:43:33]  [06/03/2020 17:03:50]  [03/02/2020 09:29:38]  [14/06/2018 21:02:34]
  [21/03/2019 14:00:08]  [28/03/2019 16:16:12]  [08/01/2020 18:37:09]  [28/12/2019 05:05:00]  [14/12/2019 18:21:21]

Newest emails in Inbox
  [20/03/2020 12:16:47]  [20/03/2020 00:00:14]  [19/03/2020 17:51:21]  [19/03/2020 17:06:38]  [19/03/2020 10:19:36]
  [18/03/2020 16:21:25]  [18/03/2020 01:43:37]  [17/03/2020 11:14:29]  [16/03/2020 20:39:58]  [16/03/2020 16:48:40]
  [15/03/2020 19:43:16]  [14/03/2020 08:58:11]  [14/03/2020 08:07:35]  [14/03/2020 03:42:53]  [13/03/2020 17:31:23]
  [13/03/2020 08:46:58]  [12/03/2020 00:07:53]  [11/03/2020 13:43:33]  [06/03/2020 17:03:50]  [03/02/2020 09:29:38]

Oldest emails in Inbox
  [14/06/2018 21:02:34]  [21/03/2019 14:00:08]  [28/03/2019 16:16:12]  [14/12/2019 18:21:21]  [28/12/2019 05:05:00]
  [08/01/2020 18:37:09]  [03/02/2020 09:29:38]  [06/03/2020 17:03:50]  [11/03/2020 13:43:33]  [12/03/2020 00:07:53]
  [13/03/2020 08:46:58]  [13/03/2020 17:31:23]  [14/03/2020 03:42:53]  [14/03/2020 08:07:35]  [14/03/2020 08:58:11]
  [15/03/2020 19:43:16]  [16/03/2020 16:48:40]  [16/03/2020 20:39:58]  [17/03/2020 11:14:29]  [18/03/2020 01:43:37]

Things to note:

I have Dim OutApp As New Outlook.Application. The “New” says create the reference rather than just create a data item for a reference. This means I do not need GetObject or CreateObject. Outlook will only allow one occurrence of itself at a time so my “New” or your CreateObject will reference an existing occurrence or create a new one as necessary. I also have OutApp.Quit at the end. This closes Outlook whether or not it was already open. I don’t use Outlook while using Excel workbooks to access Outlook, so I want Outlook to be closed. If you care, use your Get or Create code but record which was successful, so you know if Quit is needed.

I have named my data item OutApp instead of olApp. Outlook uses the prefix “ol” for its constants, so I avoid this prefix in case my name matches one of Outlook’s.

I have used Session instead of GetNamespace("MAPI"). They are just different ways of achieving the same effect.

ItemsInbox is a “Collection”; what other languages call a “List”. A collection is like an array except you can add new entries before any existing entries, in the middle or after any existing entries. Any existing entries can be removed.

Outlook adds new emails at the end of the collection. So, if you read from first to last, the first email is the one that has been in Inbox longest first. If you read from last to first, the first email is the one that was added to Inbox most recently. This suggests that you can read from last to first and see the most recent emails first and you can stop when you reach an out-of-range email. However, if you move an old email from Inbox to another folder then move it back, it will not be returned to its old position; instead it will be added to the end.

In the macro below, I first list the ReceivedTime of twenty emails from first to last then from last to first. You may see that some are out of sequence.

I then list ReceivedTime of twenty emails after sorting by ReceivedTime in descending then ascending sequence.

Study the four blocks of dates. In particular, note the different sequences. I believe the code behind the third block of dates will be the most suitable for you.

I think I have covered everything but, as I said, come back will questions if necessary and I will repair any deficiencies.

Option Explicit

  ' Needs reference to "Microsoft Outlook n.nn Object Library"
  ' where n.nn depends on the version of Outlook you are using.

Sub Demo()

  Dim FldrInbox As Outlook.Folder
  Dim InxICrnt As Long
  Dim InxIMax As Long
  Dim ItemsInbox As Outlook.Items
  Dim NumOnLine As Long
  Dim OutApp As New Outlook.Application

  Set FldrInbox = OutApp.Session.Folders("a.j.dallimore@xxxxxxx.com").Folders("Inbox")

  Set ItemsInbox = FldrInbox.Items

  If ItemsInbox.Count > 20 Then
    InxIMax = 20
  Else
    InxIMax = ItemsInbox.Count
  End If

  Debug.Print "Oldest additions to Inbox"
  NumOnLine = 0
  For InxICrnt = 1 To InxIMax
    Debug.Print "  [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
    NumOnLine = NumOnLine + 1
    If NumOnLine = 5 Then
      Debug.Print
      NumOnLine = 0
    End If
  Next
  Debug.Print

  Debug.Print "Newest additions to Inbox"
  NumOnLine = 0
  For InxICrnt = InxIMax To 1 Step -1
    Debug.Print "  [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
    NumOnLine = NumOnLine + 1
    If NumOnLine = 5 Then
      Debug.Print
      NumOnLine = 0
    End If
  Next
  Debug.Print

  ItemsInbox.Sort "ReceivedTime", True
  Debug.Print "Newest emails in Inbox"
  NumOnLine = 0
  For InxICrnt = 1 To InxIMax
    Debug.Print "  [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
    NumOnLine = NumOnLine + 1
    If NumOnLine = 5 Then
      Debug.Print
      NumOnLine = 0
    End If
  Next
  Debug.Print

  ItemsInbox.Sort "ReceivedTime", False
  Debug.Print "Oldest emails in Inbox"
  NumOnLine = 0
  For InxICrnt = 1 To InxIMax
    Debug.Print "  [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
    NumOnLine = NumOnLine + 1
    If NumOnLine = 5 Then
      Debug.Print
      NumOnLine = 0
    End If
  Next
  Debug.Print

  Set ItemsInbox = Nothing
  OutApp.Quit
  Set OutApp = Nothing

End Sub

Revised requirement

Every week or so, you receive an email from a vendor containing an invoice in both PDF and XLSX formats. An Outlook rule recognises that email and moves it to a dedicated folder. Your team is not interested in the PDF version. The XLSX workbook does not have a consistent name. However, it consistently contains a worksheet “Shipped” that contains data that would be useful to your team. At present, you will not attempt to process that data by macro but you would like it consolidated into your own workbook so it can be viewed conveniently by the team. At present, the desired format is:

Columns B to K of row 4+ of worksheet “Shipped” for week starting 1Mar20
    :    :    :    :    :
Columns B to K of row 4+ of worksheet “Shipped” for week starting 8Mar20
    :    :    :    :    :
Columns B to K of row 4+ of worksheet “Shipped” for week starting 15Mar20
    :    :    :    :    :

Reviewed ideas on achieving requirement

If you had asked a few months ago, I would have suggested linking the macro to the rule with “Run a script”. Microsoft has decided that “Run a script” is dangerous and it is no longer available by default. There is online help which explains how to make “Run a script” available but I suggest you wait until you are more experienced before attempting this.

I would suggest a revised format for the consolidated data:

Data from email received 2Mar20 9:10
   Entire contents of worksheet “Shipped”
Data from email received 9Mar20 9:30
   Entire contents of worksheet “Shipped”
Data from email received 16Mar20 9:20
   Entire contents of worksheet “Shipped”

The heading rows mean there is no possible confusion about where one week’s data ends and another starts. Including the heading rows from the worksheet and all columns means that if they add another column it will still be included in your consolidation and you will have a warning if they change the sequence.

The macro does not have to be in the same workbook as the data. I usually keep the macro and the data separate for this type of task. The data is updated regularly, but the macro is only updated occasionally. For example, I download my bank statements every month and merge them into a continuous statement running back years. I only change the macro when they change the format of the download.

You do not need code that recognises the email by, for example, testing the UnRead property because the email of interest will be the latest in the dedicated folder. There is a possibility that you will call the macro before the new email has arrived, so the macro looks at last week’s email. If it checks the latest header within the consolidated worksheet, it will know it has an old workbook and can exit without making changes.

The following is my suggestion. Do not worry if you do not know how to achieve some of my ideas because I do know how to.

You have two workbooks with names like “Consolidation Macros V02.xlsm” and “Consolidated Data V25.xlsx”. Whenever a new invoice arrives, you open the latest consolidation macros workbook and start the consolidate macro. It is possible to start macros automatically when a workbook is opened but I suggest we leave that for the moment. The macro opens the latest data workbook and notes the date of the most recent addition. It accesses Outlook, finds the latest invoice email and checks its date against the date of the most recent addition. Unless the date of the latest invoice email is later that the latest addition, the macro terminates. If the date is satisfactory, the macro finds the XLSX attachment and saves it to disc. It opens that workbook, checks for worksheet “Shipped” and adds its contents to the bottom of worksheet “Shipped” within the latest consolidated data worksheet and saves the workbook with the next version number.

You will have noticed that I have a version number for each workbook. During my working life I saw too many disasters because people did not save a new version whenever they updated a file. I can drop the version numbers if you do not want them.

Do you think the above matches your requirement?

Answer 3

"... to extract email attachments starting from date which I enter in dialog box (I want to extract email attachments just for emails which I received in last seven day not the whole folder)."

Option Explicit

Sub Extract_attachments_recent_emails()

    ' code for Excel

    Dim olApp As Object
    Dim olMail As Object
    Dim olItems As Object
    Dim olfolder As Object

    Dim J As Long

    Dim strFolder As String

    Dim ageDays As Long
    Dim strFilter As String
    Dim resItems As Object

    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        Set olApp = CreateObject("Outlook.Application")
    End If

    strFolder = ThisWorkbook.Path & "\Extract"
    Set Olfolder = olApp.GetNamespace("MAPI").Folders("MyEmailAddress").Folders("Inbox")

    Set olItems = olfolder.items

    ' save time with hardcoded number
    'ageDays = 7

    ' be flexible with InputBox
    ageDays = InputBox("ageDays", "Input age of oldest mail in days", "7")

    strFilter = "[ReceivedTime]>'" & Format(Date - ageDays, "DDDDD HH:NN") & "'"

    Set resItems = olItems.Restrict(strFilter)

    For Each olMail In resItems

        If olMail.Attachments.Count > 0 Then
            For J = 1 To olMail.Attachments.Count
                OlMail.Attachments.Item(J).SaveAsFile strFolder & "\" & OlMail.Attachments.Item(J).Filename
            Next J
        End If

    Set olMail = Nothing

    Next

    MsgBox ("Done")

End Sub