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!

 

[tonyyy]

In viewing your other posts, it seems the 30+ workbooks are attachments to email messages in a folder(s) on your hard drive. The following is intended only to open each mail message and save its attachments to a specified folder.

Sub GetMSG()

Dim FolderName As String

With Application.FileDialog(msoFileDialogFolderPicker)
  .AllowMultiSelect = False
  .Show
  On Error Resume Next
  FolderName = .SelectedItems(1) & "\"
  Err.Clear
  On Error GoTo 0
End With

' True includes subfolders; False to check only listed folder
ListFilesInFolder FolderName, True
   
End Sub

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 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
 
' path to save attachments ***** Change this to your own path *****
strFolderpath = "C:\Doc's 2015\2015 Gigs\MrExcel\MailWithAttachments\Attachments\"
 
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
 
For Each FileItem In SourceFolder.Files
    strFile = FileItem.Name
    strFileType = LCase$(Right$(strFile, 4))
    If strFileType = ".msg" Then
        Set openMsg = Outlook.Application.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
                strAttach = strFolderpath & strAttach
                objAttachments.Item(i).SaveAsFile strAttach
            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
      
End Sub

The first macro opens a File Dialog and prompts you to select a Folder. The Folder path is then passed to the second macro, which then saves the attachments into another folder.

You'll need to reference two libraries:
Microsoft Scripting Runtime
Microsoft Outlook 14.0 Object Library
In the VBE, go to Tools/References and select each.

You'll also need to change path that specifies the folder in which to save the attachments:
' path to save attachments ***** Change this to your own path *****
strFolderpath = "C:\Doc's 2015\2015 Gigs\MrExcel\MailWithAttachments\Attachments\"

There are many other posts in the Forum regarding consolidating multiple workbooks into a single workbook.

Cheers,

tonyyy

 

[bmrr2]

Hi tonyyy! Thank you so much for this! It looks like exactly what I need.

So far it's opening the first e-mail and saving the attachment on my shared drive, which is awesome! Now I just need to get it to open the other 30+ e-mails in that folder though... Does it need a loop or do I need to change one of the variables in the first or second macro?

Also, potentially related to that: I'm not sure why, but after it opens and saves the first one, I'm getting a Run-time error (462) "The remote server machine does not exist or is unavailable".

Any assistance with this is very much appreciated. By the way, I hadn't found anything like this code... it is extremely appreciated and my coworkers will be extremely happy with the results -- thank you.

-Amber

 

[bmrr2]

I see now that the For Each loop should catch all File Items in the folder. Now when I'm running it I'm getting a new error though: Run-time error '-2147417848 (80010108)' "Automation error: The object invoked has disconnected from its clients".

 

[tonyyy]

Hello Amber,

To determine if the errors are macro or network issues, please:

Copy several mail messages to a folder on your local drive;
Change the path for strFolderpath to a folder on your local drive;
Run the macro.
When reporting errors, in addition to noting the error number and description, please also note the line of code on which the error occurs.

Thanks,

tonyyy

 

[bmrr2]

Hi Tonyyy

After copying the folder with messages and attachments to my local drive and updating the strFolderpath as such, I'm getting the same result (first message's attachment saved) but a new error: Run-time error '-2147023170 (800706be)' "Automation error: The remote procedure call failed".

Then when I click debug, the following line of code is highlighted: Set openMsg = Outlook.Application.CreateItemFromTemplate(FileItem.Path)

I'm sorry for the previous omission, but I'll learn

Thank you.

 

[tonyyy]

Amber,

Here's what I found regarding the specific error messages:

CAUSE
Visual Basic has established a reference to Outlook due to a line of code that calls an Outlook object, method, or property without qualifying it with an Outlook object variable. Visual Basic does not release this reference until you end the program. This errant reference interferes with automation code when the code is run more than once.
RESOLUTION
Modify the code so that each call to an Outlook object, method, or property is qualified with the appropriate object variable.

So, the code below includes an Outlook object variable in the offending line. There may be more lines that will cause errors - more likely than not - so we'll need to identify each in an iterative process.

The code is also a bit different than the preceding code, in that it now consolidates the data from the 30+ files into the current workbook, into Sheet1 - renamed to "Raw Data". Displaying each mail message has been turned off and screen updating has been suppressed in order to speed up the process.

Cheers,

tonyyy

Sub GetMSG()

Dim FolderName As String

With Application.FileDialog(msoFileDialogFolderPicker)
  .AllowMultiSelect = False
  .Show
  On Error Resume Next
  FolderName = .SelectedItems(1) & "\"
  Err.Clear
  On Error GoTo 0
End With

' True includes subfolders; False to check only listed folder
ListFilesInFolder FolderName, True
   
End Sub

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))
                    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
Application.ScreenUpdating = True

End Sub

 

[bmrr2]

tonyyy: You are brilliant!! Thank you so much No issues, yet

 

[tonyyy]

Amber,

Please, do let me know if you encounter issues.

To finish up your initial requests...
Add a column to indicate the Bin number;
Add a column to copy and reformat the date from Column I.

Add this routine to the same module as the others.

Note: For isolating the Bin number, it's assumed the folder path closely matches that in the example:
S:\2015\Nov 2015\111615 655am folder\Bin 1 E-mail

Sub BinNumber()

Dim LastRow As Long
Dim r As Range
Dim Found1 As Integer

LastRow = Cells(Rows.Count, "M").End(xlUp).Row
For Each r In Range("M1:M" & LastRow)
    Found1 = InStrRev(Range("M" & LastRow).Value, "\")
    r.Value = Right(r.Value, (Len(r) - Found1))
    r.Value = Replace(r.Value, " E-mail", "")
Next r

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

End Sub

Near the end of the main macro, insert the following call...

[COLOR=#808080]Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing

[/COLOR][B]Call BinNumber[/B][COLOR=#808080]
Application.ScreenUpdating = True

End Sub[/COLOR]

 

[tonyyy]

Sorry, just noted an error...

In the BinNumber routine, please replace this line:

Found1 = InStrRev(Range("M" & LastRow).Value, "\")

With this:

Found1 = InStrRev(r.Value, "\")

Thanks,

tonyyy