Macro to extract worksheet from every workbook in a folder

[timspin]

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

 

[BrianB]

Something like this :-

http://www.mrexcel.com/board2/viewtopic.php?t=145246&highlight=

 

[timspin]

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

 

[BrianB]

This should do it (untested)

'==============================================================
'- 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

 

[timspin]

ADVERTISEMENT

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

 

[BrianB]

You have to put this with my other code to replace the subroutine with the same name.

 

[timspin]

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

 

[BrianB]

I'm glad you cracked it.