Function BrowseForFolder(Optional OpenAt As Variant, Optional Prompt As String) As String
'Function purpose: To Browse for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'If the "Promp" is provided it will appear below the dialog header bar.
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, Prompt, 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Public Function GetFileNames(oPath As String, Optional fExt As String) As String()
'Function Purpose: Returns an array of the file names in the oPath directory.
'If the optional fExt is provided only files matching the extension are returned.
'If fExt is not provided then all files are returned.
Dim FileArray() As String
Dim fname As String
Dim SlashExt As String
Dim count As Integer
If fExt <> "" Then
If Left(fExt, 1) = "." Then fExt = Right(fExt, Len(fExt) - 1) 'Allows fExt to be specified with or without "."
SlashExt = "\*." & fExt
Else
SlashExt = "\*.*" 'Set extension to all if option fExt is not provided
End If
ReDim FileArray(1 To 2)
fname = Dir(oPath & SlashExt) 'Get first file name
count = 0
Do Until fname = "" ' Start the loop.
count = count + 1
ReDim Preserve FileArray(1 To count)
FileArray(count) = fname
fname = Dir ' Get next entry.
Loop
GetFileNames = FileArray
End Function
Public Function LastRow(MySheet As Excel.Worksheet) As Integer
LastRow = MySheet.UsedRange.Rows.count + MySheet.UsedRange.Row - 1
End Function
Sub MashFiles()
'Procedure Purpose: Consolidate data from multiple spreadheets into a single spreadsheet.
'Works only with ActiveWorkBook.Sheets(1)
'For each of the multiple spreadsheets ActiveWorkBook.Sheets(1).Name is inserted into Column A of the consolidated sheet.
Dim aPath As String
Dim FileArray() As String
Dim i As Long
Dim r As Integer
Dim myxlapp As Object
Dim DestinationFile As String
Dim DestinationFolder As String
Dim MasterIndex As Excel.Workbook
Dim MasterSheet As Excel.Worksheet
Dim PartIndex As Excel.Workbook
Dim PartSheet As Excel.Worksheet
'Select the path containing the files to process and load .xls files into an array
aPath = BrowseForFolder(, "Select Folder with Files for Processing")
FileArray = GetFileNames(aPath, "xls")
'Set up a file to hold the composite
DestinationFile = InputBox("Name for Destination Spreadsheet")
If Right(DestinationFile, 4) <> ".xls" Then DestinationFile = DestinationFile & ".xls"
DestinationFolder = BrowseForFolder(, "Select a folder for the Destination Spreadsheet")
'open an Excel spreadsheet
Set myxlapp = CreateObject("Excel.Application")
Set MasterIndex = myxlapp.Workbooks.Add
Set MasterSheet = MasterIndex.Worksheets(1)
myxlapp.Visible = True
'Run though each file and do stuff
Application.ScreenUpdating = False
For i = 1 To UBound(FileArray)
fullfilename = aPath & "\" & FileArray(i)
Set PartIndex = myxlapp.Workbooks.Open(fullfilename)
Set PartSheet = PartIndex.Sheets(1)
PartSheet.Columns("A:A").Insert shift:=xlToRight
For r = 1 To LastRow(PartSheet)
PartSheet.Cells(r, 1).Value = PartSheet.Name
Next r
PartSheet.UsedRange.Copy
MasterSheet.Range("A1").Cells(LastRow(MasterSheet) + 1, 1).PasteSpecial
PartIndex.Save
PartIndex.Close
Next i
MasterIndex.SaveAs (DestinationFolder & "\" & DestinationFile)
Application.ScreenUpdating = True
End Sub
