Open .csv file from Outlook email and copy tab into current workbook

[Billy Hill]

I want to be able to open multiple emails one at a time from the same sender with similar subjects, open the attached .csv file, then move that tab to the original workbook, close the email then process the next one.

The emails come from MyAlerts with "Product Structure for XXXXXXXXXX" in the subject. The email contains a .csv file with the file name variable XXXXXXXXXX that will be between 6 and 10 characters long.

The email subject may look like this: Product Structure for 1234567

And have an attachment that looks like this: 1234567.csv

I created a rule to move those emails to a folder called BOMs when they arrive so they will all be in the same place.

Thanks in advance!

 

[ask2tsp]

Hello,
I wrote a little piece of code to help you on your way.

1. create a sheet, name it Parameters and define the following named cells
name contents
mailbox the email addres
folderPath Something like "Inbox\group\final" no backslash at begin/end
subjectFragment a filter you can apply, in your case probably "Product Structure for"
saveDir Path to directory to save your attachments (if that's what you want)

Start Visual Basic (ALT+F11)
In the project Explorer select the Parameters sheet. Go to the properties pane (F4) and change the first item (the object name) to parms.

Now in the project Explorer select the project select 'insert module' from the context menu.
Paste the following code in the code window that just opened
-----
note: this is not exactly what you asked for, but it is the framework that gets you through all your mails and attachments.
Give it a try.
Good luck with it

Option Explicit
 
Public Sub GetOutlook()
   Dim olApp   As Outlook.Application
   Dim MAPI    As Outlook.Namespace
   Dim mailBox As Outlook.MAPIFolder
   
   Dim mailBoxName   As String
   Dim MailObject    As Object
   
   Dim folder        As Object
   Dim pathToFolder  As String
   Dim folders()     As String
   Dim folderLevel   As Integer
   
   Dim subjectFragment  As String
   Dim subFolder        As Object
   Dim cRow    As Long
   Dim found   As Boolean
   
   Set olApp = CreateObject("Outlook.Application")
   Set MAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
   
   mailBoxName = parms.Range("mailbox")
   Set mailBox = MAPI.folders(mailBoxName)
   
   pathToFolder = parms.Range("folderPath")
   folders = Split(pathToFolder, "\")
   
   subjectFragment = parms.Range("subjectFragment")
   
   cRow = 3
   contents.Cells(3, 1).CurrentRegion.ClearContents
   
   folderLevel = 0
   For Each folder In mailBox.folders
      
      If folder.Name = folders(folderLevel) Then
         found = True
         While folderLevel < UBound(folders) And found
            folderLevel = folderLevel + 1
            found = False
            For Each subFolder In folder.folders
               If subFolder.Name = folders(folderLevel) Then
                  found = True
                  Exit For
               End If
            Next subFolder
         Wend
         
         If found Then
            For Each MailObject In subFolder.Items
               If InStr(1, MailObject.Subject, subjectFragment) Then
                  processMail MailObject
               End If
            Next MailObject
         End If
         
      End If
      
   Next folder
   
   Set olApp = Nothing
End Sub

Sub processMail(mi As MailItem)
   Dim att     As Attachment
   Dim attPath As String
   
   attPath = parms.Range("saveDir")
   
   For Each att In mi.Attachments
      att.SaveAsFile attPath + "\" + att.Filename
   Next att
End Sub