Открывайте вложения из нескольких папок, копируйте их содержимое и сохраняйте в мастер-файле

Question

Эта задача выполнима с помощью запроса пользователя, такого как:

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

Ситуация:
Я требую, чтобы пользователь не взаимодействовал с данными (ручной выбор нескольких данных),Нам нужно получить доступ к файлам Excel в нескольких папках (ограничено днем ​​загрузки из Outlook), чтобы открыть их, как только вложения из Outlook будут загружены в соответствующие папки. Затем мне нужно выполнить цикл, чтобы скопировать содержимое всех выбранных листов в один файл Excel (Masterfile). На следующий день это должно продолжаться, если вложение / данные не будут извлечены в течение двух и более дней назад (только днем ​​ранее).

Текущий код извлекает вложения из Outlook, и я застрял на этом этапе.

Я бы сказал, что мы придерживаемся соглашения о кодировании для более быстрой и быстрой обработки:

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\rootname\OneDrive\Desktop\VBATesting\"

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

Примерно так:

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

    Const SUMMARY_WB As String = "C:\Path\ToYour\Summary\Workbook.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