Hi
I have written a macro for you.
Open the attached text file and copy the procedures (everything) to VBS.
Run 'Copy_worksheets_Master' procedure.
For this to work
you need to copy all the files to a folder..
When you run the macro, it will ask you to select a folder where you stored
the files..
Once you select a folder, it will open each of the file and copy every
sheets in each folder to a new file
not very optimized code but it should do the trick you want.
I tested and worked for me. Let me know how it went..
Hope this helps
See ya
Mark Kim
--
----------------------------------------------------------------------------------
Some important links for excel users:
1. Follow us on TWITTER for tips tricks and links :
http://twitter.com/exceldailytip
2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310
3. Excel tutorials at http://www.excel-macros.blogspot.com
4. Learn VBA Macros at http://www.quickvba.blogspot.com
5. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to excel-macros@googlegroups.com
<><><><><><><><><><><><><><><><><><><><><><>
Like our page on facebook , Just follow below link
http://www.facebook.com/discussexcel
Option Explicit
Sub Copy_worksheets_Master()
Dim p As String, x As Variant
Dim i As Long, CopyTo_wk As Workbook
Dim j As Long
Dim CopyFrom_wk As Window
Dim Number_of_sheets As Long
p = Getfolder & "\"
x = GetFileList(p)
Set CopyTo_wk = Workbooks.Add
Select Case IsArray(x)
Case True 'files found
MsgBox UBound(x)
For i = LBound(x) To UBound(x)
Openworkbook (p & x(i))
Set CopyFrom_wk = Windows(x(i))
CopyFrom_wk.Activate
Number_of_sheets = ActiveWorkbook.Worksheets.Count
For j = 1 To Number_of_sheets
CopyFrom_wk.Activate
ActiveWorkbook.Sheets(j).Copy after:=CopyTo_wk.Sheets(CopyTo_wk.Sheets.Count)
Next
CopyFrom_wk.Close Savechanges:=True
Next i
Case False 'no files found
MsgBox "No Files Found"
End Select
End Sub
Function Getfolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a location"
.Show
If .SelectedItems.Count = 0 Then
Getfolder = "Canceled"
Else
Getfolder = .SelectedItems(1)
End If
End With
End Function
Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim Filename As String
On Error GoTo NoFilesFound
FileCount = 0
Filename = Dir(FileSpec & "*.xls")
If Filename = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While Filename <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = Filename
Filename = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
Sub Openworkbook(FilenamePath As String)
Workbooks.Open (FilenamePath)
End Sub
