VBA Code


Sub CombineFiles() 
' Written by Barrie Davidson 
Dim Rollup_File_Name As String 
Dim File_Names As Variant 
Dim File_count As Integer 
Dim Active_File_Name As String 
Dim Counter As Integer 
Dim File_Save_Name As Variant 
    
File_Names = Application.GetOpenFilename _ 
    ("Excel Files (*.xl*), *.xl*", , , , True) 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
File_count = UBound(File_Names) 
Counter = 1 
Workbooks.Add 
Rollup_File_Name = ActiveWorkbook.Name 
Do Until Counter > File_count 
    Active_File_Name = File_Names(Counter) 
    Workbooks.Open FileName:=Active_File_Name 
    Active_File_Name = ActiveWorkbook.Name 
    If Counter = 1 Then 
        Range("A1:K" & Range("A65536").End(xlUp).Row).Copy _ 
            Destination:=Workbooks(Rollup_File_Name). _ 
            Sheets(1).Range("A1") 
    Else 
        Range("A2:K" & Range("A65536").End(xlUp).Row).Copy _ 
            Destination:=Workbooks(Rollup_File_Name). _ 
            Sheets(1).Range("A65536").End(xlUp).Offset(1, 0) 
    End If 
    Workbooks(Active_File_Name).Close False 
    Counter = Counter + 1 
Loop 
GetSaveName: 
File_Save_Name = Application.GetSaveAsFilename(, _ 
    "Excel Files (*.xls), *.xls") 
Select Case File_Save_Name 
    Case Is = False 
        MsgBox ("Please enter a file name to save the file") 
        GoTo GetSaveName 
    Case Is = "" 
        MsgBox ("Please enter a file name to save the file") 
        GoTo GetSaveName 
    Case Else 
End Select 
Workbooks(Rollup_File_Name).SaveAs FileName:=File_Save_Name 
Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
End Sub