CODE --> VBA(excel)

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