Macro to compile data from multiple excel files into one summary file

[Kiwirunner]

Hi,

I have one hundred excel files that have the same identical format but have different guest names, guest addresses and arrival dates. What I am trying to do is write a macro that goes into each file, looks to see how many guest names are in each file and then copies this information along with the guests address information into a summary excel sheet.

The 100 identical excel files look as follows (each file will be saved as the group name i.e. "Group 12"):

A B C D E
1 Group 12
2
3 Guest Name Address Arrival Date
4 Joe Bloggs Australia 21/1/12
5 James Henry UK 22/1/12
6 Sarah Henry UK 22/1/12

I am trying to get the summary file to look as follows:

A B C D E
1 Summary File
2
3 Group Guest Name Address Arrival Date
4 12 Joe Bloggs Australia 21/1/12
5 12 James Henry UK 22/1/12
6 12 Sarah Henry UK 22/1/12
7 13 Andrew Walker UK 28/2/12
8 13 Kate Henly USA 29/2/12
9 14 Andy Eaden A 29/2/12

Any help in pointing me in the right direction here would be most appreciated.

Thanks and have a happy NYE!

 

[jskasango]

Hi jbeaucaire ,
Although your solution is like 6 years old, I believe it is what I have been hunting for the last two weeks! My scenario is this: For each year I have sub-folders that contain the excel files with unique names that I need to summarize. I want to pick a specific sheet from each file (Results Sheet). Labels are in row 1. Data starts from row 25 and the files have different number of rows with data. Use the first file for headers and match the headers because in some cases the header might be in a different column. If a file has a new header, create that header in row 1 and continue. jbeaucaire, if I can get this code to complete the exercise!! I might just get my job back!!! I need to extract this information from 2004 to 2017! I already spent 2 weeks without moving! PLEASE HELP!

 

[anderma8]

Hi everyone - odd question about this file consolidator tool: If I were to append the filename where the range of data is coming from, how could I do this since the copy effort is done via a range? Honestly, this is a FANTASTIC tool! It's saved me a TON of time and introduced me to VB!

 

[jskasango]

I had a similar issue and foound a solution here: https://www.rondebruin.nl/win/s3/win008.htm
Thanks to Ron de Bruin!

 

[andreipocovnicu]

Hello all,

Can someone please help me with an issue I am having with the code Jerry shared on this thread? I have made amendments to align with my requirements, but I cannot get the code to copy the information over from the excel files - it only copies the information from one file and the last row from another file. I will eventually end up with hundreds of excel files in "New Folder" and I need the information in Range [B18: B & LR] to be copied from spreadsheet "Hours Input" of each excel workbook to "Summary" in my current workbook.

Another issue I have is with copying over values only (rather than formatting too), as I get an error due to merged cells. I cannot make any changes to the template of the workbooks in "New folder", but I could unmerge all cells in "Hours input" before moving into "Imported" folder without saving the changes. Any ideas how to do that?

Option Explicit

Sub Consolidate()

Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet


'Setup
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now

Set wsMaster = ThisWorkbook.Sheets("Summary") 'sheet report is built into

With wsMaster
If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
.UsedRange.Offset(1).EntireRow.Clear
NR = 2
Else
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data
End If

'Path and filename (edit this section to suit)
fPath = "C:\Users\andrei.pocovnicu\Desktop\Forecasting tool\New folder" 'remember final \ in this string
fPathDone = fPath & "Imported" 'remember final \ in this string
On Error Resume Next
MkDir fPathDone 'creates the completed folder if missing
On Error GoTo 0
fName = Dir(fPath & "*.xls*") 'listing of desired files, edit filter as desired

'Import a sheet from found files
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
Set wbData = Workbooks.Open(fPath & fName) 'Open file

'Edit this
Sheets("Hours Input").Activate
LR = Range("C" & Rows.Count).End(xlUp).Row 'Find last row
Range("B18:B" & LR).EntireRow.Copy .Range("A" & NR)
wbData.Close False 'close file
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'Next row
Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder
End If
fName = Dir 'ready next filename
Loop
End With

ErrorExit: 'Cleanup
ActiveSheet.Columns.AutoFit
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub

 

[waljbt]

Hi Jerry, just to let you know that you're code was helpful once more. Thanks and have a great day