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!

 

[VoG]

See if this helps http://msdn.microsoft.com/en-us/library/cc837974.aspx

 

[jbeaucaire]

Here's a basic macro to get you started. Edit the fPath to the folder where your files are stored.

Option Explicit

Sub ImportGroups()
Dim fPATH As String, fNAME As String
Dim LR As Long, NR As Long
Dim wbGRP As Workbook, wsDEST As Worksheet

Set wsDEST = ThisWorkbook.Sheets("Summary")
NR = wsDEST.Range("B" & Rows.Count).End(xlUp).Row + 1

fPATH = "C:\2011\GroupFiles\"       'remember the final \ in this string

fNAME = Dir(fPATH & "*.xls")        'get the first filename in fpath

Do While Len(fNAME) > 0
    Set wbGRP = Workbooks.Open(fPATH & fNAME)   'open the file
    LR = Range("B" & Rows.Count).End(xlUp).Row  'how many rows of info?
    
    If LR > 3 Then
        wsDEST.Range("A" & NR) = Replace(Range("A1"), "Group ", "")
        Range("B4:E" & LR).Copy wsDEST.Range("B" & NR)
        NR = wsDEST.Range("B" & Rows.Count).End(xlUp).Row + 1
    End If
    
    wbGRP.Close False   'close data workbook
        fNAME = Dir         'get the next filename
Loop

With Range("A3:A" & NR - 1)
    .FormulaR1C1 = "=R[-1]C"
    .Value = .Value
End With

End Sub

 

[Kiwirunner]

Thanks Jerry, that's awesome. Works well and will definitely use it. Two quick questions I have thou are as follows? How do I get it so the right group number/name appears in column A? At present the summary excel sheet shows the same group number against all the different groups?

My second question is how would I say

 

[Kiwirunner]

sorry hit enter too early and have figured out the answer to my second question. Thanks, George

 

[jbeaucaire]

Oops... my apologies, correct this code:

With Range("A3:A" & NR - 1)
    .FormulaR1C1 = "=R[-1]C"
    .Value = .Value
End With

...to this:

Range("A3:A" & NR - 1).SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
With Range("A3:A" & NR - 1)
    .Value = .Value
End With

 

[Kiwirunner]

Thanks Jerry.

Two further questions. If the data is in "sheet 3" of every excel sheet how do get the macro to look in "sheet 3" everytime instead of "sheet 1". Secondly, how do I get the data copied to appear in the summary sheet as values only (and not show codes from each individual worksheet)?

Cheers,
George

 

[jbeaucaire]

How about:

Option Explicit

Sub ImportGroups()
Dim fPATH As String, fNAME As String
Dim LR As Long, NR As Long
Dim wbGRP As Workbook, wsDEST As Worksheet

Set wsDEST = ThisWorkbook.Sheets("Summary")
NR = wsDEST.Range("B" & Rows.Count).End(xlUp).Row + 1

fPATH = "C:\2011\GroupFiles\"       'remember the final \ in this string

fNAME = Dir(fPATH & "*.xls")        'get the first filename in fpath

Do While Len(fNAME) > 0
    Set wbGRP = Workbooks.Open(fPATH & fNAME)   'open the file
    LR = wbGRP.Sheets("Sheet3").Range("B" & Rows.Count).End(xlUp).Row  'how many rows of info?
    
    If LR > 3 Then
        wsDEST.Range("A" & NR) = Replace(Range("A1"), "Group ", "")
        wbGRP.Sheets("Sheet3").Range("B4:E" & LR).Copy
        wsDEST.Range("B" & NR).PasteSpecial xlPasteValuesAndNumberFormats
        NR = wsDEST.Range("B" & Rows.Count).End(xlUp).Row + 1
    End If
    
    wbGRP.Close False   'close data workbook
    fNAME = Dir         'get the next filename
Loop

wsDEST.Range("A3:A" & NR - 1).SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
With wsDEST.Range("A3:A" & NR - 1)
    .Value = .Value
End With

End Sub

 

[Ashwin_max]

Here's a basic macro to get you started. Edit the </SPAN>fPath</SPAN> to the folder where your files are stored.


Hi Jerry,
I think you are the man who I am looking for!!

I have a urgent requirement where in i need to merge data from multiple files-> create a summary report-> mail this report. I had been googling for this from last 2 days and had registered over some other excel help forums too but no luck.

Today i came across the solution of yours and was surprised to see, it really works. I tired to modify it as per my requirements and after 5+ hours of trail and error i thought of getting your help.

Can you please modify the code below for:
1) Reading data from 2nd row for all .xls files available in a folder and append data to a master file(input file can have any number of rows but number of columns will be fixed only 7 columns)
2) Take 1st row of any input file and make it as a header for Master file.
3) If master file already has data- delete all.
4) Format the master file, so that all cells are set to wrap text(so that contents are in readable format)
5) Mail Master file to a email address.


I am sure you can help me Jerry writing a code for above requirement. I can understand that you are very busy but if possible I would request you to include comments in your code, this would help me understand macro programming better.</SPAN>


Thanks very very much in advance!!

 

[jbeaucaire]

Here's a macro for collecting data from all files in a specific folder.

Workbooks to 1 Sheet​

The parts of the code that need to be edited are colored to draw your attention.

It expects you to have the column headers already in place, that wouldn't be a problem, right?

Down in the "This is the section to customize", it's a pretty simple tweak to copy from A2 down:

        'This is the section to customize, replace with your own action code as needed
            LR = Range("A" & Rows.Count).End(xlUp).Row  'Find last row
            Range("A2:G" & LR).Copy .Range("A" & NR)
            wbData.Close False                                'close file

At the end of the macro you can insert your code to format the columns with wrap text, use the macro recorder to get the base code if needed.

The "email part" I don't do with automation, so you'll have to run that as a separate task.