How to move and copy multiple sheets into a single workbooks

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.

Export Groups of Sheets to New Workbooks

<!-- language: lang-vb -->

Sub ExportSheets()
' Define constants.
Const DELIMITER As String = "-"
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' In each 'key' of a dictionary, return a unique workbook name while
' adding each associated sheet name to a 'key' of another dictionary held
' in the associated 'item' of the initial dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim sh As Object, DelPos As Long, wbName As String, shName As String
For Each sh In wb.Sheets
' Prevent 'mayhem' if the only sheet of a group is hidden or very hidden
' i.e. very hidden sheets will never get copied but either won't
' raise an error if at least one of the sheets is visible.
' To simplify, exlude both.
If sh.Visible = xlSheetVisible Then
shName = sh.Name
DelPos = InStr(shName, DELIMITER)
' Prevent error if the sheet name starts with the delimiter.
If DelPos > 1 Then
wbName = Left(shName, DelPos - 1)
If Not dict.Exists(wbName) Then
Set dict(wbName) = CreateObject("Scripting.Dictionary")
End If
dict(wbName)(shName) = Empty
End If
End If
Next sh
If dict.Count = 0 Then
MsgBox "No sheets found.", vbCritical
Exit Sub
End If
' Define the path: use the same path as the workbook (modify as required).
Dim wbPath As String: wbPath = wb.Path
' Using the 'keys' (the workbook names) and the 'items'
' (the 1D arrays of sheet names ('keys')), export each group of sheets
' to a new workbook, then save and close the workbook.
Application.ScreenUpdating = False
Dim Key, FilePath As String
For Each Key In dict.Keys
wb.Sheets(dict(Key).Keys).Copy ' return the sheets in a new workbook
With Workbooks(Workbooks.Count) ' reference this new workbook
' The following is all you need to save as a '.xlsx' file
' i.e. you don't need to specify the file extension.
FilePath = wbPath & Application.PathSeparator & Key
Application.DisplayAlerts = False ' overwrite without confirmation
.SaveAs FilePath
Application.DisplayAlerts = True
.Close SaveChanges:=False
End With
Next Key
Application.ScreenUpdating = True
' Inform.
MsgBox "Sheets exported.", vbInformation
End Sub

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.

Since you didn't provide more details whether you want to have the process fully automatic or you want to run the macro manually for particular sheet names or how you put in the desired sheet name you are looking for, I made it quite simple. Provided code is a working sample. Kindly adjust it by your specific needs.

Method CopySheets asks you for base sheet name you are looking for (35100001, etc.) and maintains the whole process of copying worksheets.
It calls the method GetSheetsArray which searches for sheet names which met your criteria in current workbook and return them as Variant array.
Finally it creates new workbook where it will copy all relevant worksheets and saves the workbook in the same folder as current workbook. Name of the workbook is always identical with the sheet name you were looking for (35100001, etc.) .

Public Sub CopySheets()
'Ask for the base sheet name you are looking for (35100001, etc.)
Dim BaseSheetName As String
BaseSheetName = InputBox(Prompt:="Base sheet name")
'Array containing sheet names which fit your criteria.
Dim SheetsArray As Variant
SheetsArray = GetSheetsArray(BaseSheetName)  
Dim wbNew As Workbook
Set wbNew = Application.Workbooks.Add
'Select and copy sheets.
With ThisWorkbook
.Worksheets(SheetsArray).Select
.Activate
ActiveWindow.SelectedSheets.Copy After:=wbNew.Worksheets(1)
End With
'Delete the default sheet in newly created workbook. In case you have 3 default sheets, delete them in cycle.
Application.DisplayAlerts = False
wbNew.Worksheets(1).Delete
Application.DisplayAlerts = True
'Save new workbook in same directory as this workbook and give it a name
'you were looking for. Adjust the saving path by your preferences.
wbNew.SaveAs Filename:=ThisWorkbook.Path & "\" & BaseSheetName, _
FileFormat:=XlFileFormat.xlOpenXMLWorkbook
wbNew.Close
End Sub

The Output array in following function is not really necessary and GetSheetsArray can be used directly. But I prefer to use it this way because if function name changes in the future, it needs to be modified only at one place, at the end of the function. It makes programmer's life easier.

Private Function GetSheetsArray(ByVal LookupName As String) As Variant
'Basic initialization of output array.
Dim Output As Variant
ReDim Output(1)
Dim i As Long: i = 0
'Store all relevant sheet names in array.
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If InStr(1, ws.Name, LookupName, vbTextCompare) > 0 Then
ReDim Preserve Output(i)
Output(i) = ws.Name
i = i + 1
End If
Next ws
GetSheetsArray = Output
Erase Output
End Function

If you want to search for worksheet names which met your criteria in workbook other then current workbok, you can easily modify the GetSheetsArray function by adding the reference to a workbook as an input parameter.

Private Function GetSheetsArray(ByVal LookupName As String, _
ByVal wb As Workbook) As Variant

Then within the function body you have to replace ThisWorkbook by wb.

  For Each ws In wb.Worksheets
'...
Next ws