Macro to Pull Data from New Workbooks Created Daily

[bmrr2]

Hello

I am trying to get data from 30+ workbooks into a new workbook. The 30+ are created daily, generated via e-mail; those e-mails are pasted into a new folder each day with the date and time. I need to pull the data from each workbook into a tab titled "Raw Data" in another daily workbook and add a column to state which e-mail (Bin) it came from (1, 2, etc.) and another column to reformat a date in column I from a specific time and date to just the date (or with the time set at 0:00 works).

Example file path: S:\2015\Nov 2015\111615 655am folder\Bin 1 E-mail\Inbox1_11161525.csv

However, if I could just get all of the data from each workbook pulled over to a new sheet, that would be tremendously helpful. The issue that I anticipate having is that the name of the folders that the data are in change daily due to the date change in addition to the time that the reports are pulled changing daily.

The data is typically in columns A-L but the number of rows varies per spreadsheet and date. I believe that we're using Windows XP.

Any help would be greatly appreciated. Thank you!

 

[bmrr2]

Good Morning tonyyy

I’m sorry that I haven’t gotten back to you sooner regarding feedback for the code. The second of the two columns that are being added in the spreadsheet is correctly pulling over the Date from Col I and reformatting it. However, the first of those two columns is generating the text “QA Bins Raw Data” for every row in Col M.

I’m wondering if we could get the name that the e-mails are saved as to populate in that column (M), as the e-mail name includes the Bin # (the name of the spreadsheets do not include the Bin# or else I would ask for that instead as I’d imagine it would be easier).

I’m not sure if this will matter for the code, but the Bin# typically populates as the last one to two digits of the e-mail name (ex. “******* ******** *** *** ** Bins - Part 22“ or “******* ******** *** *** ** Bins - Part 1”), usually the 42^nd and 43^rd characters (including spaces) – that may be entirely too specific, I’m not sure, but would certainly help if it could be narrowed down that far.

Thank you for your help! And again, I'm sorry for the delay. The rest of the code seems to be working perfectly

-Amber

 

[tonyyy]

Good Morning Amber,

When you refer to email names I'm going to interpret that as meaning the email Subject, and as such I've tweaked the main macro to populate Column M with the last 2 characters of the Subject.

I've also consolidated the BinNumber routine into the main macro so you can delete that part of the code.

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)

' set a reference to Microsoft Scripting Runtime
' set a reference to Microsoft Outlook 14.0 Object Library

Dim oOutlook As Outlook.Application ''''''''
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim strFile, strFileType, strAttach As String
Dim openMsg As MailItem
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFolderpath As String
Dim wb1 As Workbook, wb2 As Workbook
Dim LastRow1 As Long, LastRow2 As Long
Dim NextRow As Long
Dim StartRow As Long
Dim fName As String

Application.ScreenUpdating = False
' path to save attachments ***** Change this to your own path *****
strFolderpath = "C:\Doc's 2015\2015 Gigs\MrExcel\MailWithAttachments\Attachments\"

Set oOutlook = CreateObject("Outlook.Application") ''''''''
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'''''''''''''''''''''''''''''''''''''''''''
Set wb1 = ThisWorkbook
wb1.Sheets(1).Name = "Raw Data"
LastRow1 = 1
'''''''''''''''''''''''''''''''''''''''''''
For Each FileItem In SourceFolder.Files
    strFile = FileItem.Name
    strFileType = LCase$(Right$(strFile, 4))
    If strFileType = ".msg" Then
        Set openMsg = oOutlook.CreateItemFromTemplate(FileItem.Path) ''''''''
'        openMsg.Display
        Set objAttachments = openMsg.Attachments
        lngCount = objAttachments.Count
              
        If lngCount > 0 Then
            For i = lngCount To 1 Step -1
                strAttach = objAttachments.Item(i).Filename
                fName = strAttach
                Debug.Print fName
                
                strFileType = LCase(Right(fName, 4))
                Debug.Print strFileType
                If strFileType = ".csv" Or strFileType = "xlsx" Or strFileType = "xlsm" Then
                    strAttach = strFolderpath & strAttach
                    objAttachments.Item(i).SaveAsFile strAttach
                    Set wb2 = Workbooks.Open(strAttach)
                    LastRow2 = Cells(Rows.Count, "A").End(xlUp).Row
                    Range("A1:L" & LastRow2).Copy Destination:=wb1.Sheets("Raw Data").Range("A" & LastRow1)
                    StartRow = LastRow1
                    NextRow = wb1.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
                    wb1.Activate
'                    wb1.Sheets("Raw Data").Range(Cells(StartRow, 13), Cells(NextRow, 13)) = Left(strAttach, (Len(strAttach) - Len(fName) - 1))
                    wb1.Sheets("Raw Data").Range(Cells(StartRow, 13), Cells(NextRow, 13)) = Right(openMsg.Subject, 2) ''''' This line extracts the Bin # from the email Subject
                    LastRow1 = Cells(Rows.Count, "A").End(xlUp).Row + 1
                    wb2.Close savechanges:=False
                End If
            Next i
        End If
        
        openMsg.Close olDiscard
        Set objAttachments = Nothing
        Set openMsg = Nothing
    End If
Next FileItem

If IncludeSubfolders Then
    For Each SubFolder In SourceFolder.SubFolders
        ListFilesInFolder SubFolder.Path, True
    Next SubFolder
End If
 
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing

'Call BinNumber
Dim LastRow As Long
LastRow = Cells(Rows.Count, "M").End(xlUp).Row
ThisWorkbook.Sheets("Raw Data").Range("N1:N" & LastRow).Value = ThisWorkbook.Sheets("Raw Data").Range("I1:I" & LastRow).Value
Range("N1:N" & LastRow).NumberFormat = "m/d/yyyy"
ThisWorkbook.Sheets("Raw Data").Columns.AutoFit

Application.ScreenUpdating = True

End Sub

Hope this helps, and if we don't chat later today - have a safe and Happy Thanksgiving!

tonyyy

 

[bmrr2]

Hi tonyyy!!!

I apologize for the very delayed response; I was hoping that I would get you an answer on Wednesday, but unfortunately I only had a moment to play around with it and was getting an error. So, this morning I deleted what I had thus far and just re-pasted in your code... and it works beautifully. Thank you so much! And, I hope that you had a wonderful Thanksgiving, too!

-Amber

 

[tonyyy]

Glad it worked out, Amber.

Cheers,

tonyyy

 

[bmrr2]

I had a weird occurrence running the macro this morning (after it working seamlessly before!), and I’m not exactly sure how to troubleshoot it because there wasn’t an actual typical Error flagged by the macro. Basically, it took longer than usual to run (about ten minutes actually) and gave me a copy of 32 of the 33 spreadsheets from the 33 e-mails that there were to field through and gave me data for only 31 of the 33 spreadsheets.

For the spreadsheet that was saved but the data was not included in the output, that spreadsheet opened up for me toward the end of the macro running. The one that did not save did not open up.

I should note that the e-mails that the macro is looking at are shared and can only be opened by one user at a time; now that I’m writing this out, I’m realizing that that’s probably the culprit, but I’m not certain. Any insight regarding this? I’m just not sure what other sort if information I would need to provide, so please ask away if I haven’t included anything pertinent to this.

Thank you again for all of your help with this!

-amber

 

[bmrr2]

Hi tonyyy

I had a weird occurrence running the macro this morning (after it working seamlessly before!), and I’m not exactly sure how to troubleshoot it because there wasn’t an actual typical Error flagged by the macro. Basically, it took longer than usual to run (about ten minutes actually) and gave me a copy of 32 of the 33 spreadsheets from the 33 e-mails that there were to field through and gave me data for only 31 of the 33 spreadsheets.

For the spreadsheet that was saved but the data was not included in the output, that spreadsheet opened up for me toward the end of the macro running. The one that did not save did not open up.

I should note that the e-mails that the macro is looking at are shared and can only be opened by one user at a time; now that I’m writing this out, I’m realizing that that’s probably the culprit, but I’m not certain. Any insight regarding this? I’m just not sure what other sort if information I would need to provide, so please ask away if I haven’t included anything pertinent to this.

Thank you again for all of your help with this!

-amber

 

[tonyyy]

Hello Amber...

As you've already noted and suspected, an open email message will not be handled by the macro very well, or at all. There are 3 additions in the following code. Now, when encountering an open email message, the code will display an error number and description; buried in the description will be the name of the open email message, giving you an opportunity to make a note to handle this message and its attachment manually. The code will then skip to the next email message.

The code additions are set between pairs of comment lines (''''''''''''''''''''''''''''''''''''''''''') - so you can add just the changes to your existing module, or if you prefer, copy/paste the entire routine.

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)

' set a reference to Microsoft Scripting Runtime
' set a reference to Microsoft Outlook 14.0 Object Library

Dim oOutlook As Outlook.Application
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim strFile, strFileType, strAttach As String
Dim openMsg As MailItem
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFolderpath As String
Dim wb1 As Workbook, wb2 As Workbook
Dim LastRow1 As Long, LastRow2 As Long
Dim NextRow As Long
Dim StartRow As Long
Dim fName As String

Application.ScreenUpdating = False
' path to save attachments ***** Change this to your own path *****
strFolderpath = "C:\Doc's 2015\2015 Gigs\MrExcel\MailWithAttachments\Attachments\"

Set oOutlook = CreateObject("Outlook.Application") 
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Set wb1 = ThisWorkbook
wb1.Sheets(1).Name = "Raw Data"
LastRow1 = 1
'''''''''''''''''''''''''''''''''''''''''''
On Error GoTo ErrHandler:
'''''''''''''''''''''''''''''''''''''''''''
For Each FileItem In SourceFolder.Files
    strFile = FileItem.Name
    strFileType = LCase$(Right$(strFile, 4))
    If strFileType = ".msg" Then
        Set openMsg = oOutlook.CreateItemFromTemplate(FileItem.Path)
'        openMsg.Display
        Set objAttachments = openMsg.Attachments
        lngCount = objAttachments.Count
              
        If lngCount > 0 Then
            For i = lngCount To 1 Step -1
                strAttach = objAttachments.Item(i).Filename
                fName = strAttach
                strFileType = LCase(Right(fName, 4))
                If strFileType = ".csv" Or strFileType = "xlsx" Or strFileType = "xlsm" Then
                    strAttach = strFolderpath & strAttach
                    objAttachments.Item(i).SaveAsFile strAttach
                    Set wb2 = Workbooks.Open(strAttach)
                    LastRow2 = Cells(Rows.Count, "A").End(xlUp).Row
                    Range("A1:L" & LastRow2).Copy Destination:=wb1.Sheets("Raw Data").Range("A" & LastRow1)
                    StartRow = LastRow1
                    NextRow = wb1.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
                    wb1.Activate
                    wb1.Sheets("Raw Data").Range(Cells(StartRow, 13), Cells(NextRow, 13)) = Right(openMsg.Subject, 2) ''''' This line extracts the Bin # from the email Subject
                    LastRow1 = Cells(Rows.Count, "A").End(xlUp).Row + 1
                    wb2.Close savechanges:=False
                End If
            Next i
        End If
        
        openMsg.Close olDiscard
        Set objAttachments = Nothing
        Set openMsg = Nothing
    End If
'''''''''''''''''''''''''''''''''''''''''''
Skip:
'''''''''''''''''''''''''''''''''''''''''''
Next FileItem
If IncludeSubfolders Then
    For Each SubFolder In SourceFolder.SubFolders
        ListFilesInFolder SubFolder.Path, True
    Next SubFolder
End If
 
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing

Dim LastRow As Long
LastRow = Cells(Rows.Count, "M").End(xlUp).Row
ThisWorkbook.Sheets("Raw Data").Range("N1:N" & LastRow).Value = ThisWorkbook.Sheets("Raw Data").Range("I1:I" & LastRow).Value
Range("N1:N" & LastRow).NumberFormat = "m/d/yyyy"
ThisWorkbook.Sheets("Raw Data").Columns.AutoFit

Application.ScreenUpdating = True
'''''''''''''''''''''''''''''''''''''''''''
Exit Sub
ErrHandler:
    MsgBox "Error Number: " & Err.Number & ", " & Err.Description
    Resume Skip:
'''''''''''''''''''''''''''''''''''''''''''
End Sub

Cheers,

tonyyy