Solved: Copy sheets into 1 workbook

[Jokada]

Hi,

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!

Regards
Jokada

[Rembo]

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.

Rembo


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
.NewSearch
.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
NewWKB.Worksheets(l).Delete
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
Else
MsgBox "No matching workbooks found in directory " & strPath
End If
End With
Application.ScreenUpdating = True
End Sub

[Jokada]

Hi,

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)
Windows(FileName).Activate
tWB.Sheets("Aankoopprijs").Select
tWB.Sheets("Aankoopprijs").Copy After:=Workbooks("2.xls").Worksheets(Workbooks("2.xls").Worksheets.Count)
Windows(FileName).Activate
tWB.Sheets("Verkoopprijs").Select
tWB.Sheets("Verkoopprijs").Copy After:=Workbooks("3.xls").Worksheets(Workbooks("3.xls").Worksheets.Count)
Windows(FileName).Activate
tWB.Sheets("Katalogus FR").Select
tWB.Sheets("Katalogus FR").Copy After:=Workbooks("4.xls").Worksheets(Workbooks("4.xls").Worksheets.Count)
Windows(FileName).Activate
tWB.Sheets("Prix d'achat").Select
tWB.Sheets("Prix d'achat").Copy After:=Workbooks("5.xls").Worksheets(Workbooks("5.xls").Worksheets.Count)
Windows(FileName).Activate
tWB.Sheets("Prix de vente").Select
tWB.Sheets("Prix de vente").Copy After:=Workbooks("6.xls").Worksheets(Workbooks("6.xls").Worksheets.Count)
Windows(FileName).Activate
'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
Loop
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