Results 1 to 3 of 3

Thread: Solved: Copy sheets into 1 workbook

  1. #1
    VBAX Newbie
    Dec 2005

    Solved: Copy sheets into 1 workbook


    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
    but this copies all info into 1 worksheet...

    Can someone help me out on this one?

    Thanks in advance!


  2. #2
    Hello Jokada,

    Quote Originally Posted by 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.


    [VBA]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[/VBA]

  3. #3
    VBAX Newbie
    Dec 2005

    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts