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!

 

[BrianB]

I do not have time to do the complete job for you. Hopefully you can use this as a basic structure.

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

*Instead of a single master workbook you will need to have your 6 open.
*You will not need to worry about row numbers.
*You then need to amend Private Sub Transfer_data() to copy sheets to your 6 workbooks. Code something like :-

Private Sub Transfer_data()
    Workbooks.Open FileName:=FromBook
    '---------------------------------
    FromBook.Worksheets(1).Copy _
        after:=Workbooks("Book1.xls").Worksheets(Workbooks("Book1.xls").Worksheets.Count)
    FromBook.Worksheets(2).Copy _
        after:=Workbooks("Book2.xls").Worksheets(Workbooks("Book2.xls").Worksheets.Count)
    '--------------------------------------------
    Workbooks(FromBook).Close savechanges:=False
End Sub

 

[Jokada]

Thanks Brian! I'll give it a try and post the findings

 

[Jokada]

Hi,

I've tested the code but it gives me a "Out of range error" at the fisrt copy statement:

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
            Set tWB = Workbooks.Open(FileName:=Path & FileName) 'open file, set to tWB variable
              If (i < 5) Then
                    
                    tWB.Sheets("Katalogus NL").Select
                    tWB.Sheets("Katalogus NL").Copy after:=Workbooks("1.xls").Worksheets(Workbooks("1.xls").Worksheets.Count)   '------errors here
                    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
                End If
                
            tWB.Close False 'close temporary workbook without saving
            End If
        End If
        FileName = Dir() 'set next file's name to FileName variable
    Loop

End Sub

Any ideas whan I'm doing wrong here?
I've got all XLS files open he should write to...

 

[BrianB]

That error usually means that it cannot find the named workbook or worksheet.

 

[Jokada]

Hi,

I got it to work now:

tWB.Sheets(1).Select 
tWB.Sheets("1").Copy after:=Workbooks("1.xls").Worksheets(Workbooks("1.xls").Worksheets.Count)
Windows(FileName).Activate

I replaced the actual sheet names by their index.
Also removed the quotes in Windows(FileName).Activate

Anyway Brian big thanks for the help!

 

[Norie]

Charles

I know you have a solution but I just want to point out that you don't need to activate/select in the code.

With this line you have created a reference to the newly opened workbook.

Set tWB = Workbooks.Open(FileName:=Path & FileName) 'open file, set to tWB variable

You can use this in later code like this.

  tWB.Sheets("Katalogus NL").Copy after:=Workbooks("1.xls").Worksheets(Workbooks("1.xls").Worksheets.Count)   '------errors here
                    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").Copy after:=Workbooks("4.xls").Worksheets(Workbooks("4.xls").Worksheets.Count)
                    tWB.Sheets("Prix d'achat").Copy after:=Workbooks("5.xls").Worksheets(Workbooks("5.xls").Worksheets.Count)
                    tWB.Sheets("Prix de vente").Copy after:=Workbooks("6.xls").Worksheets(Workbooks("6.xls").Worksheets.Count)

Obviously change this code to use the indexes as mentioned in your last post.