How to move and copy multiple sheets into a single workbooks

Question

I'm trying to copy and groups of sheets to a new workbook using VBA. But the number of sheets in a group can change depending on a criterion.

For example: 35100001-1, 35100001-2, 35100001-3 are sheet names in one workbook.

Now I want to copy sheets with sheet name having the character same these into a single workbook , so here I want a new excel workbook containing these sheets:

35100001 workbook

• 35100001-1 35100001-2 35100001-3 worksheets

35100002 workbook

• 35100002-1 35100002-2 35100002-3 worksheets

35100003 workbook

• 35100003-1 35100003-2 35100003-3 35100003-4 worksheets

35100004 workbook

• 35100004-1 35100004-2 worksheets

I'm trying to copy and groups of sheets to a new workbook using VBA. But the number of sheets in a group can change depending on a criterion.

thanks for the help, i really appreciate it.

Answer 1

Here is a complete worked example. Principle:

1. Work out the names of all the workbooks I will need

2. Create those workbooks

3. Step through every sheet in the workbook and copy to its new home

4. Save and close all the open workbooks

   Option Explicit

   Sub demo()

    Dim ws As Worksheet, colSheets As Collection, wbName As String
    Set colSheets = New Collection
    'First work out the names of other workbooks to create
    For Each ws In ThisWorkbook.Sheets
        wbName = Left(ws.Name, InStr(ws.Name, "-") - 1)
        On Error Resume Next 'force the loop to ignore duplicate keys
        colSheets.Add wbName, wbName
        On Error GoTo 0 'reset error handling
    Next
   
    'Now go create those workbooks - and save in same folder as current workbook
    Dim x As Variant, wb As Workbook
    For Each x In colSheets
        Set wb = Workbooks.Add(1) 'forces the workbook to only have 1 sheet
        'Turn off warnings in case this is a re-run
        Application.DisplayAlerts = False
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & x
        Application.DisplayAlerts = True
    Next
   
    'Now just copy each sheet to it's relevant new home
    For Each ws In ThisWorkbook.Sheets
        wbName = Left(ws.Name, InStr(ws.Name, "-") - 1) & ".xlsx"
        ws.Copy After:=Workbooks(wbName).Sheets(Workbooks(wbName).Sheets.Count)
    Next
   
    'Tidy up the new workbooks
    For Each x In colSheets
        Set wb = Workbooks(x & ".xlsx")
        Application.DisplayAlerts = False
        wb.Sheets("Sheet1").Delete
        Application.DisplayAlerts = True
        wb.Close SaveChanges:=True
    Next
   

   End Sub

Plenty of room for improvement - e.g. error handling, skip any known sheets that you don't want to copy etc., etc.