View Full Version : Solved: Copy sheets into 1 workbook

12-08-2005, 02:42 AM

I have about 50 xls files with each 6 sheets.

Now I would like to create 6 workbooks with 50 sheets.

What I need:

for all files in a certain directory:
copy all sheet(1) to a given workbook(1.xls) as a new sheet.
copy all sheet(2) to given workbook(2.xls) as a new sheet.
... for all 6 sheets

I found something similar here http://vbaexpress.com/kb/getarticle.php?kb_id=773
but this copies all info into 1 worksheet...

Can someone help me out on this one?

Thanks in advance!


12-08-2005, 08:26 AM
Hello Jokada,

for all files in a certain directory:
copy all sheet(1) to a given workbook(1.xls) as a new sheet.
copy all sheet(2) to given workbook(2.xls) as a new sheet.
... for all 6 sheets

Copy the code below into a module and run the macro ProcessWorksheets to see if that solves your problem.


Sub ProcessWorksheets()
Dim strPath As String, strFilename As String
strPath = InputBox("Enter path", "Gimme a path to search in", "C:\")
' Enter here (partial) workbook name without dot and extension.
' Leave blank for all worksbooks in that directory.
strFilename = InputBox("Enter filename", "So what am I looking for?")
fileExistAndOpen strPath, strFilename
End Sub

Sub fileExistAndOpen(strPath As String, strFilename As String)
Dim l As Long, lFilesFound As Long
Dim i As Integer
Dim NewWKB As Workbook
Application.ScreenUpdating = False
With Application.FileSearch
.LookIn = strPath
.SearchSubFolders = False
.MatchTextExactly = False
.Filename = strFilename
.FileType = msoFileTypeExcelWorkbooks
lFilesFound = .Execute
If lFilesFound >= 1 Then
For i = 1 To 6
On Error Resume Next
Set NewWKB = Workbooks.Add
Application.DisplayAlerts = False
For l = 1 To 3
Next l
Application.DisplayAlerts = True
For l = 1 To lFilesFound
Workbooks.Open .FoundFiles(l)
Worksheets(i).Copy after:=NewWKB.Worksheets(NewWKB.Worksheets.Count)
Workbooks(Workbooks.Count).Close SaveChanges:=False
Next l
NewWKB.Close SaveChanges:=True, Filename:="C:\" & i & ".xls"
Next i
MsgBox "No matching workbooks found in directory " & strPath
End If
End With
Application.ScreenUpdating = True
End Sub

12-13-2005, 01:12 AM

thx for the reply!

I've come up with the following code:

Private Sub Transfer_data()
Dim Path As String 'string variable to hold the path to look through
Dim FileName As String 'temporary filename string variable
Dim tWB As Workbook 'temporary workbook (each in directory)

Path = ThisWorkbook.Path
If Right(Path, 1) <> Application.PathSeparator Then 'if path doesnt end in "\"
Path = Path & Application.PathSeparator 'add "\"
End If
i = 0
FileName = Dir(Path & "*.xls", vbNormal) 'set first file's name to filename variable
Do Until FileName = "" 'loop until all files have been parsed
If Path <> ThisWorkbook.Path Or FileName <> ThisWorkbook.Name Then
If (InStr(FileName, "01.06.xls") Or InStr(FileName, "2006.xls")) Then
If (i < 3) Then
Application.DisplayAlerts = False
Set tWB = Workbooks.Open(FileName:=Path & FileName) 'open file, set to tWB variable
ActiveWorkbook.UpdateRemoteReferences = False
Application.DisplayAlerts = True

tWB.Sheets("Katalogus NL").Select
tWB.Sheets("Katalogus NL").Copy After:=Workbooks("1.xls").Worksheets(Workbooks("1.xls").Worksheets.Count)
tWB.Sheets("Aankoopprijs").Copy After:=Workbooks("2.xls").Worksheets(Workbooks("2.xls").Worksheets.Count)
tWB.Sheets("Verkoopprijs").Copy After:=Workbooks("3.xls").Worksheets(Workbooks("3.xls").Worksheets.Count)
tWB.Sheets("Katalogus FR").Select
tWB.Sheets("Katalogus FR").Copy After:=Workbooks("4.xls").Worksheets(Workbooks("4.xls").Worksheets.Count)
tWB.Sheets("Prix d'achat").Select
tWB.Sheets("Prix d'achat").Copy After:=Workbooks("5.xls").Worksheets(Workbooks("5.xls").Worksheets.Count)
tWB.Sheets("Prix de vente").Select
tWB.Sheets("Prix de vente").Copy After:=Workbooks("6.xls").Worksheets(Workbooks("6.xls").Worksheets.Count)
'ActiveWorkbook.Close savechanges:=False
i = i + 1

tWB.Close False 'close temporary workbook without saving

End If
End If
End If
FileName = Dir() 'set next file's name to FileName variable
For i = 1 To 3
Workbooks("1.xls").Worksheets (Workbooks("1.xls").Worksheets("Blad" & i).Delete)
Workbooks("2.xls").Worksheets (Workbooks("2.xls").Worksheets("Blad" & i).Delete)
Workbooks("3.xls").Worksheets (Workbooks("3.xls").Worksheets("Blad" & i).Delete)
Workbooks("4.xls").Worksheets (Workbooks("4.xls").Worksheets("Blad" & i).Delete)
Workbooks("5.xls").Worksheets (Workbooks("5.xls").Worksheets("Blad" & i).Delete)
Workbooks("6.xls").Worksheets (Workbooks("6.xls").Worksheets("Blad" & i).Delete)
Next i

End Sub

It works! Thank you for your help