Copying many workbooks into one workbook

Lost in Quality

New Member
Joined
Jul 28, 2009
Messages
9
Hi,

I wonder if someone can help me please?

I have many excel files(nearly 500 in total and growing daily) in a folder called "Results Data" on my C drive. The file names are slightly different (serial numbers). Each excel file contains data in Cells A2:E11. I want to be able to copy only the Cells A2, B4, D5 and E10 from each workbook and paste them into a new workbook, each copied workbook on a new row.

I have been trying to change code that I have found on the web but nothing seems to be working, its like monkey tennis with me:confused:

Thanks in advance for your time and effort.
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
create a new workbook and paste the following into a new module

Code:
 Sub getData()
    Application.ScreenUpdating = False
    fldr = "c:\results data\"
    Set ts = ActiveSheet
    a = Array("file", "A2", "B4", "D5", "E10")
    ts.Range("A1:E1") = a
    d = Dir(fldr & "*.xls")
    r = 2
    Do While d <> ""
        ts.Cells(r, 1) = d
        Set nw = Workbooks.Open(fldr & d)
        For c = 2 To 5
            ts.Cells(r, c) = nw.Sheets(1).Range(a(c - 1)).Value
        Next
        nw.Close
        r = r + 1
        d = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

When you run it the required data will appear in the current worksheet. 500+ files might take a while, so I'd go make a brew. you might want to run it on a smaller subset first, just in case...
 
Last edited:
Upvote 0
Thanks very Much.

It works excatly how I imagined.:)

Took your suggestion and tried it out first on a small sample of files.

If you dont mind me asking another question of you? could you give me the name of a good book or website in order for me to try and learn and hopefully understand. I would like to have a go myself.

Thanks again

All the best
 
Upvote 0
Hi
save the file with the following codes in the folder C:\resultsdata\ and run the macro. It pulls data from closed file. since you have only 4 values per file, I believe it shold be faster.
Code:
Sub List()
Dim z  As Long, e As Long, g As Long
Dim f As String, h As String
Cells(1, 1) = "=cell(""filename"")"
Cells(1, 2) = "=left(A1,find(""["",A1)-1)"
Cells(2, 1).Select
f = Dir(Cells(1, 2) & "*.xls")
Do While Len(f) > 0
ActiveCell.Formula = f
ActiveCell.Offset(1, 0).Select
f = Dir()
Loop
z = Cells(Rows.Count, 1).End(xlUp).Row
For e = 3 To z
For g = 1 To 4
h = Choose(g, "A2", "B4", "D5", "E10")
Cells(2, g + 1) = h
Cells(1, 3) = "='" & Cells(1, 2) & "[" & Cells(e, 1) & "]Sheet1'!" & h
Cells(e, g + 1) = Cells(1, 3)
Next g
Next e
Range("A1:C1").Delete
MsgBox "collating is complete."
End Sub
Ravi
 
Upvote 0
Good point, ravi. I've done this type of task this way myself before now. It's worth knowing both methods, in case you need to change the target files as well.

LOQ as for learning how, well sometimes you've just got to get stuck in. Break your problems down into bitesized chunks and use other people's posts where you can. As you can already see, there's usually more than one way to achieve your goals, which is where I think books don't really tell the full story. I learned a lot of what I know by trial and error from this site.
 
Upvote 0
Hi Weaver,

I am not too sure what I have done but the first code worked on the small sample. But the post from you now looks a different code and all it displays on the new work book are the headings. I Accidently closed the workwork and did not save the first one I tried. School boy error I know
 
Upvote 0
Ravi's was the best idea, but I've modded it

Code:
 Sub List()
    Application.ScreenUpdating = False
    Dim z  As Long, e As Long, g As Long
    Dim f As String, h As String
    p = ActiveWorkbook.Path & "\"
    r = 2
    f = Dir(p & "*.xls")
    Do While Len(f) > 0
        If f <> ActiveWorkbook.Name Then
            Cells(r, 1) = f
            r = r + 1
        End If
    f = Dir()
    Loop
    For e = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        For g = 1 To 4
        h = Choose(g, "A2", "B4", "D5", "E10")
        Cells(1, g + 1) = h
        Cells(e, g + 1) = "='" & p & "[" & Cells(e, 1) & "]Sheet1'!" & h
        Next g
    Next e
    Application.ScreenUpdating = True
    MsgBox "collating is complete."
End Sub

Save this in a new sheet in your folder and then run it.
 
Upvote 0
Hi Ravi,

Thank you also. Yes there does seem to be more than one way to crack a nut. I am not too sure if its my set up but when I ran your code it cascaded the results, they were not all on the same row.
 
Upvote 0

Forum statistics

Threads
1,213,544
Messages
6,114,249
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top