excel - Open attachments from multiple folders, copy contents and save in Master File sheet

Question

This task is achievable with user request such as:

FileToOpen = Application.GetOpenFilename(Filefilter:="Excel Files (*.xlsx), *.xlsx", Title:="Select 
Workbook to Import", MultiSelect:=True)

If IsArray(FileToOpen) Then           
    For FileCount = 1 To UBound(FileToOpen)
        shNewDat.Cells.Clear
        LastRow = shAll.Cells(Rows.Count, 1).End(xlUp).Row + 1 
        Set SelectedBook = Workbooks.Open(FileName:=FileToOpen(FileCount))
        SelectedBook.Worksheets("Sheet1").Cells.Copy    
        shNewDat.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats

        SelectedBook.Close
        LastTempRow = shNewDat.Cells(Rows.Count, 2).End(xlUp).Row 'locate last row in the RAWData Temp tab

Situation:
I require that the user doesn't interact with data (manually multiple selecting data). We need to access Excel files in multiple folders (limited to the day of download from Outlook) to open as soon as attachments from Outlook have been downloaded into their respective folders. Then, I need to loop through to copy contents from all selected sheets to one Excel file (Masterfile). Following day, this should continue without attachment/data being pulled through from two days or more back (only the day before).

Current code pulls attachments from Outlook and I'm stuck at this point.

I would plead that we stick to the coding convention for cleaner faster processing:

Sub SaveOutlookAttachments()

Dim objOutlook As New Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.Folder

Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.Folders(1).Folders("Inbox")

ProcessMails objFolder, "compa", "North", "compa  Report UpTo", "compa North Region Report"
ProcessMails objFolder, "compa", "South", "compa  Report UpTo", "compa South Region Report"
ProcessMails objFolder, "compa", "East", "compa  Report UpTo", "compa East Region Report"
ProcessMails objFolder, "compa", "West", "compa  Report UpTo", "compa West Region Report"

End Sub

Sub ProcessMails(srcFolder As Outlook.Folder, compName As String, subj As String, _
             saveFolder As String, saveFileName As String)

Const ROOT_FOLDER As String = "C:Users
ootnameOneDriveDesktopVBATesting"

Dim objItem As Object, objMailItem As Outlook.MailItem, dirFolderName As String
Dim objAttachment As Outlook.Attachment

For Each objItem In srcFolder.Items.Restrict(PFilter(compName, subj))
    If objItem.Class = Outlook.olMail Then 'Check Item Class

        Set objMailItem = objItem 'Set as Mail Item

        If ProcessThisMail(objMailItem) Then
            With objMailItem

                dirFolderName = ROOT_FOLDER & saveFolder & _
                                Format(objMailItem.ReceivedTime, "yyyy-mm") & ""

                EnsureSaveFolder dirFolderName

                Debug.Print "Message:", objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject

                For Each objAttachment In .Attachments
                    Debug.Print , "Attachment:", objAttachment.Filename

                    objAttachment.SaveAsFile dirFolderName & _
                          saveFileName & Format(objMailItem.ReceivedTime, "yyyy-mm-dd")
                Next

            End With
        End If 'processing this one
    End If 'is a mail item
Next objItem
End Sub

'return a filter for company and subject
Function PFilter(sCompany, sSubj)
PFilter = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@" & sCompany & "%'" & _
          "AND ""urn:schemas:httpmail:subject"" LIKE '%" & sSubj & "%'"
End Function

'Abstract out the rules for when a mail is processed
Function ProcessThisMail(theMail As Outlook.MailItem) As Boolean
Dim iBackdate As Long
If theMail.Attachments.Count > 0 Then
    Select Case Weekday(Now)
        Case 7: iBackdate = 3 ' Saturday: add extra day
        Case 1, 2, 3: iBackdate = 4 ' Sunday through Tuesday: add extra 2 days
        Case Else: iBackdate = 2 ' Other days
    End Select
    If theMail.ReceivedTime > DateAdd("d", -iBackdate, Now) Then
        ProcessThisMail = True 'will by default return false unless this line is reached
    End If
End If
End Function

'ensure a subfolder exists
Sub EnsureSaveFolder(sPath As String)
With CreateObject("scripting.filesystemobject")
    If Not .FolderExists(sPath) Then
        .CreateFolder sPath
    End If
End With
End Sub

Answer 1

Something like this:

Sub ProcessMails(srcFolder As Outlook.Folder, compName As String, subj As String, _
             saveFolder As String, saveFileName As String)

    Const SUMMARY_WB As String = "C:PathToYourSummaryWorkbook.xlsx"
    Dim saveAsFileName As String


    '...
    '...

    For Each objAttachment In .Attachments

        Debug.Print , "Attachment:", objAttachment.Filename
        saveAsFileName = dirFolderName & saveFileName & Format(objMailItem.ReceivedTime, "yyyy-mm-dd")

        objAttachment.SaveAsFile saveAsFileName
        CollectWorkbookInfo saveAsFileName, SUMMARY_WB      '<< collect info from the workbook you just saved

    Next

    '...
    '...

End Sub


Sub CollectWorkbookInfo(SourcePath As String, SummaryPath As String)
    Dim wbSrc As Workbook, wbSummary As Workbook

    Set wbSrc = Workbooks.Open(SourcePath)      'source
    Set wbSummary = Workbooks.Open(SummaryPath) 'destination
    '...
    '   do your copying between wbSrc and wbSummary
    '...
    wbSrc.Close False       'don't save
    wbSummary.Close True    'save

End Sub