none
copy multiple worksheets and paste into one workbook RRS feed

  • Question

  • First Post!

    I have a workbook with ten worksheets and I am trying to copy every two worksheets into a new workbook, therefore having 5 workbook in my excel folder. 

    The name of the tab doesn't matter, so i was going to start the name of the two worksheets to be "worksheet A- Data" and "worksheet A- values". What would the if function be if i wanted to do something like "If workbook start with "Workbook A -", then move to new workbook? Or is there another approach to this?

    I have the below so far but it only copy one workshee.

    Thanks ahead of time!

    Sub Splitbook()
    For Each sht In ThisWorkbook.Sheets
    sht.Copy
    ActiveSheet.Cells.Copy
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
    ActiveWorkbook.SaveAs _
    Filename:=MyPath & Application.PathSeparator & "MyExcel" & Application.PathSeparator & sht.Name & ".xlsx", Password:="password"
    ActiveWorkbook.Close savechanges:=False
    Next sht
    End Sub



    • Edited by VBANewbie Tuesday, October 22, 2013 2:10 AM
    Tuesday, October 22, 2013 1:43 AM

All replies

  • Try the following example. No error handling has been included to test for existing workbooks by same name etc.

    Sub Splitbook()
        Dim lngDefaultSheets
        Dim lngTotSheets As Long
        Dim s As Long
        Dim wbThis As Workbook
        Dim wbNew As Workbook
        Dim ws1New As Worksheet
        Dim ws2New As Worksheet
        Dim strMyPath As String
       
       
        Set wbThis = ThisWorkbook
        strMyPath = wbThis.Path
       
        'Save the existing default number of sheets in Excel
        lngDefaultSheets = Application.SheetsInNewWorkbook
       
        Application.SheetsInNewWorkbook = 2
       
        lngTotSheets = wbThis.Worksheets.Count
       
        'Step through worksheet 2 at a time and then copy
        'and paste the sheet and the next sheet
        For s = 1 To lngTotSheets Step 2
            'Add a new workbook
            Set wbNew = Workbooks.Add
            'Assign the 2 worksheets to worksheet variables
            Set ws1New = wbNew.Worksheets(1)
            Set ws2New = wbNew.Worksheets(2)
           
            'Copy the first worksheet of loop identifier
            'and paste into the first sheet of new workbook
            'and rename the worksheet in the new workbook
            wbThis.Worksheets(s).Cells.Copy
            ws1New.Cells.PasteSpecial Paste:=xlPasteValues
            ws1New.Cells.PasteSpecial Paste:=xlPasteFormats
            ws1New.Name = wbThis.Worksheets(s).Name
           
            'Copy the next worksheet of loop identifier
            'and paste into sheet 2 of new workbook
            'and rename to the worksheet in new workbook
            wbThis.Worksheets(s + 1).Cells.Copy
            ws2New.Cells.PasteSpecial Paste:=xlPasteValues
            ws2New.Cells.PasteSpecial Paste:=xlPasteFormats
            ws2New.Name = wbThis.Worksheets(s + 1).Name
           
            wbNew.SaveAs Filename:=strMyPath & "\" & "MyExcel" & "\" _
                    & wbThis.Worksheets(s).Name & ".xlsx", Password:="password"
           
            wbNew.Close
        Next s
       
        'Reset the default number of worksheets in Excel
        Application.SheetsInNewWorkbook = lngDefaultSheets
     End Sub

     


    Regards, OssieMac

    Tuesday, October 22, 2013 9:07 AM