Macro to extract worksheet from every workbook in a folder

timspin

Board Regular
Joined
Nov 18, 2002
Messages
231
Hi all

Ive created a project report template that will go out to 15 consultants. Id like to be able to collate a work sheet called "Summary" from each of these reports into a new workbook.

My idea is to place all of the workbook into a folder, and then place into the folder my summary workbook - which when open alloows you to click a button that will run a macro that will extract from each of the workbooks in that folder the worksheet entitled "Summary".

Is this possible? any ideas?

Thanks for you help
Tim
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Hi there BrianB

I did see this and wondered if I could use it. I couldnt quite understand what is happening here. If I need to have a workbook with 15 worksheets in - one from each of the 15 workbooks in the folder - each entitled "Summary" - will this code do that?? If so where do I say its the work sheet "Summary" that needs to be extracted (as there are other worksheets in each book)

Private Sub Transfer_data()
Workbooks.Open FileName:=FromBook
For Each FromSheet In Workbooks(FromBook).Worksheets
LastRow = FromSheet.Range("A65536").End(xlUp).Row
Dim First As Boolean
First = True
If First Then
FromSheet.Copy
Set wb = ActiveWorkbook
First = False
Else
FromSheet.Copy After:=wb.Worksheets(wb.Worksheets.Count)
End If
Next
Workbooks(FromBook).Close savechanges:=False
End Sub
 
Upvote 0
This should do it (untested)
Code:
'==============================================================
'- CHANGE THIS CODE TO DO WHAT YOU WANT TO THE OPENED WORKBOOK
'==============================================================
Private Sub Transfer_data()
    Workbooks.Open FileName:=frombook
    frombook.Worksheets("Summary").Copy after:=ToBook.Worksheets(Worksheets.Count)
    Workbooks(frombook).Close savechanges:=False
End Sub
 
Upvote 0
Hithere

I tried it out - gives me an error Run time error '1004'" could not be found. Check the spelling of the file name and verify that the file location is correct" If you are trying to open the file from your list of most recently used files on the File menu, amke sure that the file has not been renamed, moved or delted
and the debugger highlites this bit of code

Workbooks.Open Filename:=frombook

Help!!
Cheers
Tim
 
Upvote 0
You have to put this with my other code to replace the subroutine with the same name.
 
Upvote 0
Hi Brian B

Still gave the error - though I am now using the folowing code with choice being made by which button I press as to which sheet is sucked out of all the workbooks.

Module code

Dim ToBook As String
Dim ToSheet As Worksheet
Dim NumColumns As Integer
Dim ToRow As Long
Dim FromBook As String
Dim FromSheet As Worksheet
Dim FromRow As Long
Dim LastRow As Long
'-
'=========================================================
'- MAIN ROUTINE
'=========================================================
Sub FILES_FROM_FOLDER2(WEEKNO)
Application.Calculation = xlCalculationManual
ChDrive ActiveWorkbook.Path
ChDir ActiveWorkbook.Path
ToBook = ActiveWorkbook.Name
'---------------------------
'- MASTER SHEET
'---------------------------
Set ToSheet = ActiveSheet
NumColumns = ToSheet.Range("A1").End(xlToRight).Column
ToRow = ToSheet.Range("A500").End(xlUp).Row
'- clear master
If ToRow <> 1 Then
ToSheet.Range(ToSheet.Cells(2, 1), _
ToSheet.Cells(ToRow, NumColumns)).ClearContents
End If
ToRow = 2
'------------------------------------------
'- main loop to open each file in folder
'------------------------------------------
FromBook = Dir("*.xls")
While FromBook <> ""
If FromBook <> ToBook Then
Application.StatusBar = FromBook
Transfer_data2 (WEEKNO) ' subroutine below
End If
FromBook = Dir
Wend
'-- close

Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
End Sub
'


Private Sub Transfer_data2(WEEKNO2)

Workbooks.Open Filename:=FromBook
Sheets(WEEKNO2).Select
Sheets(WEEKNO2).Copy After:=Workbooks("Summary bezel.xls").Sheets(1 _
)

Workbooks(FromBook).Close savechanges:=False

End Sub

and button code

Private Sub CommandButton1_Click()

FILES_FROM_FOLDER2 ("W1")
FILES_FROM_FOLDER2 ("W2")
FILES_FROM_FOLDER2 ("W3")
FILES_FROM_FOLDER2 ("W4")
FILES_FROM_FOLDER2 ("Monthly Summary")
MsgBox ("Done.")
End Sub

Private Sub CommandButton2_Click()
FILES_FROM_FOLDER2 ("W1")
MsgBox ("Done.")
End Sub

Private Sub CommandButton3_Click()
FILES_FROM_FOLDER2 ("W2")
MsgBox ("Done.")
End Sub

Private Sub CommandButton4_Click()
FILES_FROM_FOLDER2 ("W3")
MsgBox ("Done.")
End Sub

Private Sub CommandButton5_Click()
FILES_FROM_FOLDER2 ("Monthly Summary")
MsgBox ("Done.")
End Sub

Private Sub CommandButton6_Click()
FILES_FROM_FOLDER2 ("W4")
MsgBox ("Done.")
End Sub


And it seems to work just fine - though I think some of the module code is redundent

Cheers for the help BrianB
Tim
 
Upvote 0

Forum statistics

Threads
1,213,514
Messages
6,114,078
Members
448,547
Latest member
arndtea

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