Consolidating Multiple Files

[bigevs23]

Hi guys,

I'm wondering if anyone knows of any vb code to pull data from several files into one 'summary' file using file paths (eg 'C:\....[January.xls]Sheet1'!A1+'C:\....[February.xls]Sheet1'!A1+'C:\....[March.xls]Sheet1'!A1, etc).

The result will be in a file called 'C:\....[Annual Summary.xls]Sheet1'A1. All files have exactly the same layout, but the data within each is different.

I'm using a data validation list to select the files I would like to consolidate, as I would like to be able to review different combinations of files. This is why I'm not simply linking all files to the summary, which would be a lot simpler.

I'm not sure I'm making my requirements clear, but if anyone can help, it would be much appreciated.

Thanks

 

[pboltonchina]

See if you can use this

Option Explicit

'Combine Workbooks
'By Tommy Miles
'This sample goes through all the Excel files in a specified directory and combines theminto
'a single workbook.  It renames the sheets based on the name of the original workbook:
Sub CombineWorkbooks()
Dim CurFile As String, DirLoc As String
Dim DestWb As Workbook
Dim WS As Object 'allows for different sheet types

DirLoc = ThisWorkbook.path & "\tst\" 'location of files
CurFile = Dir(DirLoc & "*.xls")

Application.ScreenUpdating = False
Application.EnableEvents = False

Set DestWb = Workbooks.Add(xlWorksheet)

Do While CurFile <> vbNullString
    Dim OrigWb As Workbook
    Set OrigWb = Workbooks.Open(filename:=DirLoc & CurFile, ReadOnly:=True)
    
    ' Limit to valid sheet names and remove .xls*
    CurFile = Left(Left(CurFile, Len(CurFile) - 5), 29)
    
    For Each WS In OrigWb.Sheets
        WS.Copy after:=DestWb.Sheets(DestWb.Sheets.Count)
        
        If OrigWb.Sheets.Count > 1 Then
            DestWb.Sheets(DestWb.Sheets.Count).Name = CurFile & WS.Index
        Else
            DestWb.Sheets(DestWb.Sheets.Count).Name = CurFile
        End If
    Next
    
    OrigWb.Close SaveChanges:=False
    CurFile = Dir
Loop

Application.DisplayAlerts = False
    DestWb.Sheets(1).Delete
Application.DisplayAlerts = True

Application.ScreenUpdating = True
Application.EnableEvents = True

Set DestWb = Nothing

End Sub