Option Explicit
Sub Macro1()
'Sheets in new workbook adapted from here:
'https://www.extendoffice.com/documents/excel/3164-excel-create-workbook-with-specific-number-of-sheets.html
Dim wsSrc As Worksheet, wsDest As Worksheet
Dim clnSrcSheets As New Collection
Dim varSheet As Variant
Dim lngOldCount As Long, lngNewCount As Long
Dim lngLastRow As Long, lngLastCol As Long, lngPasteRow As Long
Dim i As Long
Dim wbSrc As Workbook, wbDest As Workbook
Application.ScreenUpdating = False
Set wbSrc = ThisWorkbook
lngOldCount = Application.SheetsInNewWorkbook
For Each wsSrc In wbSrc.Sheets
On Error Resume Next
clnSrcSheets.Add CStr(Split(wsSrc.Name, "-")(1)), Split(wsSrc.Name, "-")(1)
On Error GoTo 0
Next wsSrc
lngNewCount = clnSrcSheets.Count
If (lngNewCount < 1) Or (CLng(lngNewCount) > 255) Then
MsgBox "Cannot create a new workbook as the number of sheets must between 1 and 255 but the code has returned " & Format(lngNewCount, "#,##0") & ".", vbExclamation
Exit Sub
End If
With Application
.SheetsInNewWorkbook = lngNewCount
Set wbDest = .Workbooks.Add
.SheetsInNewWorkbook = lngOldCount
End With
For i = 1 To clnSrcSheets.Count
Set wsDest = wbDest.Sheets(i)
wsDest.Name = CStr(clnSrcSheets(i))
For Each wsSrc In wbSrc.Sheets
If InStr(wsSrc.Name, CStr(clnSrcSheets(i))) > 0 Then
If WorksheetFunction.CountA(wsSrc.Cells) > 0 Then 'https://forum.ozgrid.com/forum/index.php?thread/50992-check-if-sheet-is-empty
lngLastRow = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lngLastCol = wsSrc.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
If WorksheetFunction.CountA(wsDest.Cells) = 0 Then 'https://forum.ozgrid.com/forum/index.php?thread/50992-check-if-sheet-is-empty
'Copy data including headings
Range(wsSrc.Cells(1, 1), wsSrc.Cells(lngLastRow, lngLastCol)).Copy Destination:=wsDest.Range("A1")
Else
'Copy data excluding headings
lngPasteRow = wsDest.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Range(wsSrc.Cells(2, 1), wsSrc.Cells(lngLastRow, lngLastCol)).Copy Destination:=wsDest.Range("A" & lngPasteRow)
End If
End If
End If
Next wsSrc
Next i
Call SplitEachWorksheet(wbDest, CStr(wbSrc.Path))
Application.ScreenUpdating = True
MsgBox """" & wbDest.Name & """ has now been created with " & Format(lngNewCount, "#,##0") & " sheets from """ & wbSrc.Name & """.", vbInformation
End Sub
Sub SplitEachWorksheet(wb As Workbook, strPath As String)
Dim FPath As String
Dim ws As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each ws In wb.Sheets
ws.Copy
Application.ActiveWorkbook.SaveAs Filename:=strPath & "\" & "BT-" & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next ws
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub