Save outlook excel attachments and concatenate the data - vba

Question

I have a requirement that I am doing everyday and spending around 3 hours to do that. I would like it to be automated so that I can save time.
Every day I will get an email which contains around 100 attachments in *.msg format (Attachments are actually mails from different vendors).
In the *.msg files there will be one Excel file and this Excel file contains one line of data.
What I would like to do is Extract the first email attachments (which is in .Msg format) and extract the Excel file in each .Msg attachment and then copy the data from the XLS files into a new Excel file (Consolidating the data from each Excel attachment for calculations)!!
Can some one please provide a way to automate this process in vba macro and I would require detailed step as I am a newbie into the coding area.

Answer 1

This is as close as I can get to automating this using VBA. It's a semi-automatic solution that will require you to save the .msg attachments in a folder first and then open them all manually (i.e. select all, right-click one and chose Open). I tested this on 98 emails being opened at once, my Outlook slowed down a bit towards the end but it did not crash. The code itself takes under 3 minutes to complete the task.
But first, some assumptions were made based on the info provided:
All the .msg attachments are in one email message - if they are not, you may need to repeat step 1 as many times as necessary.
The Excel files inside the .msg files are in ".xls" format. If they are in ".xlsx" or other Excel format simply modify the relevant lines of code under Step 3.
You stated that the Excel files contain just 1 row of data - the below assumes it's row 1 in sheet 1. If not, the code will need to be adjusted slightly before it works.
Also, the solution ignores cell formatting in the Excel files - only the values from cells will be copied - this can be modified if needed.
You have some understanding of VBA, know how to insert module, compile, run and edit code in VB Editor - if not, just post your questions in a comment below, I'll be happy to help further.
The solution:
Step 1 - Save all the ".msg" attachments to a folder.
Step 2 - Select all emails in the folder and open them - this should open multiple Outlook inspector windows.
Step 3 - In Excel, activate VB Editor and paste the below code in a module:
Sub GetAttachments()
'loops through Outlook inspector windows extracting .xls attachments into a folder
Dim oShell As Object
Dim olApp As Object
Dim Insp As Object
Dim Att As Object
Dim FldPth As String
Dim myFname As String
Dim i As Long
Set olApp = CreateObject("Outlook.Application")
Set oShell = CreateObject("Shell.Application").BrowseForFolder(0, "Select Folder with attachments", 0)
If oShell Is Nothing Then MsgBox "Folder was not selected", vbCritical: Exit Sub
FldPth = oShell.self.Path
'loop through open outlook windows (inspectors)
'use reversed loop, otherwise every second iteration will be skipped
For i = olApp.Inspectors.Count To 1 Step -1
Set Insp = olApp.Inspectors.Item(i)
'loop through attachments in the email message
For Each Att In Insp.CurrentItem.Attachments
myFname = Att.Filename
'if the attached file is an xls type, save it in a folder
If LCase(Right(myFname, 4)) = ".xls" Then
Att.SaveAsFile FldPth & "\" & myFname
End If
Next Att
'close the inspector window
Insp.Close olDiscard
Next i
Set oShell = Nothing
Set olApp = Nothing
MsgBox "Done!"
End Sub
Sub GetDataFromWbks()
'loops through Excel files in selected folder extracting data from first row in sheet 1 into active worksheet
Dim oShell As Object
Dim FSO As Object
Dim f As Object
Dim srcWbk As Workbook
Dim dstWs As Worksheet
Dim srcRng As Range
Dim dstRng As Range
Dim FldPth As String
Dim i As Long
Set oShell = CreateObject("Shell.Application").BrowseForFolder(0, "Select Folder with attachments", 0)
If oShell Is Nothing Then MsgBox "Folder was not selected", vbCritical: Exit Sub
FldPth = oShell.self.Path
Set dstWs = ActiveSheet
Set dstRng = dstWs.Rows(1)
Set FSO = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
'loop through all files in folder
For Each f In FSO.GetFolder(FldPth).Files
If LCase(Right(f.Name, 4)) = ".xls" Then
'show progress in Excel's status bar
Application.StatusBar = i
'open xls file
Set srcWbk = Workbooks.Open(f.Path)
'set source range
Set srcRng = srcWbk.Sheets(1).UsedRange.Rows(1)
'copy source range to destination range
dstWs.Range(srcRng.Address).Offset(i).Value = srcRng.Value
i = i + 1
'close workbook
srcWbk.Close
End If
Next f
Application.ScreenUpdating = True
Application.StatusBar = False
Set FSO = Nothing
Set oShell = Nothing
MsgBox "Done!"
End Sub
Step 4 - Run the "GetAttachments" procedure. When prompted, select the folder you saved your attachments in. The procedure should extract all the Excel attachments from .msg files into the same folder.
Step 5 - Once done (PopUp box showed up), activate the Excel worksheet you want your data to be copied into (I suggest you use a new empty worksheet here) and run the "GetDataFromWbks" procedure - again, select your folder when prompted. You can watch the progress in Excel's status bar.
Step 6 - That's it, enjoy the saved time!