通過Outlook實現每週收到的Excel文檔

Question

我試圖更新我的儀表板中的信息，收到兩個文檔（InfoPrivate，InfoPublic）每週收到兩個Excel表。

我的儀表板包含（基本上）兩個工作表（InfoPrivate，InfoPublic）和其他我在本地進行微積分的人員。

我怎樣才能更新信息倪尋找最近的電子郵件，並更改最新版本中的每兩張數據？

我實際的代碼如下：

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 

它doesn't工作！我什至不知道爲什麼...

非常感謝誰能幫助我！ DAV

Answer 1

我終於搞定了！

這裏是代碼：

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 

再見！

Answer 2

你需要

1. 一些方法來自動最後接收的電子郵件保存到預定位置（谷歌會給你一噸的結果）
2. 假設你使用Excel的儀表板，重建它和使用Power查詢導入從文件中的數據在預定位置
3. 電源查詢將重新讀取源Excel表和更新儀表板