通过 outlook 实现每周 Excel 收到的文件

Question

我正在尝试使用每周收到的两个 excel sheet 在两个文档（InfoPrivate、InfoPublic）中收到的信息来更新我的仪表板中的信息。

我的仪表板（基本上）包含两个 sheet（InfoPrivate、InfoPublic）和其他我在其中进行局部微积分的仪表板。

我如何更新信息以查找最近的电子邮件并根据最新版本更改这两个 sheets 数据中的每一个？

我的实际代码如下：

Public Sub SaveOlAttachmentsPU()
  Dim isAttachment As Boolean
  Dim olFolder As Outlook.MAPIFolder
  Dim msg As Outlook.MailItem
  Dim att As Outlook.Attachment
  Dim sht As Worksheet, wb1, wb2 As Workbooks

  On Error GoTo crash

  isAttachment = False

  Set olFolder = Outlook.GetNamespace("MAPI").Folders(1)
  Set olFolder = olFolder.Folders("Inbox")

  If olFolder Is Nothing Then Exit Sub
     For Each msg In olFolder.Items
        If UCase(msg.Subject) = "PAC PAHO Sales Current Year" Then

            While msg.Attachments.Count > 0

           Set wb1 = msg.attachements.Open
            wb1.Sheets("PAC PAHO Sales Current Year").Copy    'on copie la feuille de la piece jointe
           Set sht = ActiveSheet                             'on récupère la copie dans un objet

           sht.Copy
            ActiveWorkbook.Sheets("PAHO").Paste

            wb1.Close

            ActiveWorkbook.SaveAs Filename:=myFileName, FileFormat:=xlsm

             Set sht = Nothing: Set wb1 = Nothing: Set wb2 = Nothing:

            isAttachment = True

            Wend
            msg.Delete
        End If
     Next
Exit Sub
Crash:
MsgBox ("BOOOM")
End Sub

没用！！！我什至不知道为什么...

非常感谢能帮助我的人！达夫

Answer 1

你需要

一些方法可以将最后收到的电子邮件自动保存到预定义的位置（google 会给你大量的结果）
假设您将 Excel 用于仪表板，重建它并使用 Power Query 从预定义位置的文件中导入数据
Power Query 将重新读取源 excel 工作表并更新仪表板

Answer 2

我终于让它工作了！

代码如下：

Sub ExportOlAttachments()

  Dim Ol As New Outlook.Application
  Dim NameSpace As Outlook.NameSpace
  Dim Dossier As Outlook.MAPIFolder
  Dim Elements As Outlook.Items
  Dim msg As Outlook.MailItem

  Dim MyPath As String

  Dim sht As Worksheet
  Dim wb1 As Workbook
  Dim wb2 As Workbook

  Set wb1 = ActiveWorkbook
  Set Ol = New Outlook.Application
  Set NameSpace = Ol.GetNamespace("MAPI")

  Set Dossier = NameSpace.GetDefaultFolder(6).Folders("I - Vientas semanal")

On Error GoTo Crash1

  For Each msg In Dossier.Items

If DateDiff("d", msg.CreationTime, wb1.Sheets("Dashboard").Range("C2")) <= 0 Then
            If msg.Subject = "source1" Then

                MyPath = "C:\Users\i0303644\Documents\Y- Others\Vientas semanal\S1"
                If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"

                msg.Attachments.Item(1).SaveAsFile MyPath & _
                msg.Attachments.Item(1).DisplayName

                Set wb2 = Application.Workbooks.Open(MyPath & "\s1")
                Set sht = wb2.Worksheets(1)

                sht.Range("C11:AQ129").Copy wb1.Sheets("PAHO").Range("C11")

                wb2.Close

                MsgBox "S1 actualized with: " & msg.Subject & " " & msg.ReceivedTime

            ElseIf msg.Subject Like "Source2*" Then

                MyPath = "C:\Users\i0303644\Documents\Y- Others\Vientas semanal\S2"
                If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"

                msg.Attachments.Item(1).SaveAsFile MyPath & _
                msg.Attachments.Item(1).DisplayName

                Set wb2 = Application.Workbooks.Open(MyPath & "\S2")
                Set sht = wb2.Worksheets(1)

                sht.Range("C9:AB115").Copy wb1.Sheets("Private_&_others").Range("C9")

                wb2.Close

                MsgBox "S2 actualized with: " & msg.Subject & " " & msg.ReceivedTime

            End If

'ElseIf Count(DateDiff("d", msg.CreationTime, wb1.Sheets("Dashboard").Range("C2")) <= 0) = 0 Then
'MsgBox "There are no new data"
End If

Next msg

wb1.Sheets("Dashboard").Range("C2").Value = Date
Set wb1 = Nothing: Set wb2 = Nothing: Set sht = Nothing:

Exit Sub
Crash1:
MsgBox ("Sometehing is not working")
End Sub

再见！

通过 outlook 实现每周 Excel 收到的文件

Actualize a document with weekly Excel received through outlook

vba

email-attachments

dashboard