Actualize a document with weekly Excel received through outlook

Question

I am trying to update the information in my dashboard with information received two excel sheet received weekly in two documents (InfoPrivate, InfoPublic).

My Dashboard contains (basically) the two sheets (InfoPrivate, InfoPublic), and others where i make local calculus.

How can I update the info ny looking for the mos recent email and change each of those two sheets data by the most recent version?

My actual code is as follow:

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

It doesn´t work !!! And i don t even have a clue why...

Thanks a lot to whoever can help me! Dav

Answer 1

I finally got it to work!

here is the code:

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

Bye!