I have reports done in Excel sent to be by various locations every month. I'd like to combine all these reports into one large report. Is there an easy way to automate this so that I can just click a button each month for this to happen instead of cut and pasting each one into the large report?
-
If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.
Consolidating reports
- Thread starter pliant
- Start date
Barrie Davidson
MrExcel MVP
- Joined
- Feb 10, 2002
- Messages
- 2,330
Can you provide some more information? For example:
What is the layout of the data? What columns are you using? Does each file have headers?
How many files are you consolidating? Is it a constant number of files or do you require a dynamic solution?
Upvote
0
Barrie Davidson
MrExcel MVP
- Joined
- Feb 10, 2002
- Messages
- 2,330
Try this code (not tested) and let me know if it works okay for you.
Regards,
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
Do Until Counter > File_count
Workbooks.Add
Rollup_File_Name = ActiveWorkbook.Name
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
Select Case File_Save_Name.Value
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 SubRegards,
Upvote
0
Barrie Davidson
MrExcel MVP
- Joined
- Feb 10, 2002
- Messages
- 2,330
geolefty said:
Close, it will prompt you to select files that you want to combine (via a file open message box), consolidate those files in a new file, and then prompt you for the file save name for the new file.
Regards,
Upvote
0
Barrie Davidson
MrExcel MVP
- Joined
- Feb 10, 2002
- Messages
- 2,330
Okay, I tested the code and found the errors. Try this instead
Let me know if I've got it now.
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 SubLet me know if I've got it now.
Upvote
0
Barrie Davidson
MrExcel MVP
- Joined
- Feb 10, 2002
- Messages
- 2,330
pliant said:
What exactly is your error message? What part of the code is getting the error? I tested the new code and it worked fine for me.
Upvote
0
Similar threads
