VBA to extract specific sheets from workbook and save them as separarte files

[AndrewAndrews]

Hello - first of likely several posts...

I have been attempting to compile a script to extract all worksheets with "..." (or some other identifier) in their name and save them as separate files in a single folder, with the file name based on the worksheet name.

The code I was hoping to modify was the below which extracts all sheets, but this takes a lot of time and power (it's a 100+ sheet workbook), and then requires further clean-up work to delete the un-needed files.

Sub SplitWorkbook()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
xWs.Copy
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub

Any and all help appreciated; I've been scouring this and other sites all week for the solution to this and other problems.

(Edit: oops - typo in the subject line...)

 

[Deepak]

Use this & check..

Application.Calculation = xlCalculationManual
code...
Application.Calculation = xlCalculationAutomatic

 

[AndrewAndrews]

Sorry, I'm very much a novice - where would that code be inserted?

 

[AndrewAndrews]

I'm almost there with the below - this workbook has 5 system sheets starting with "non", 45 calculation sheets starting with "FDD" and 45 data sheets (copied and pasted, stripped of formulae from the FDD sheets) ending in "...". This code works if I change the variable to "non" for the "non sheets", but with the "FDD" or "..." sheets I get "Method 'save as' of object '_workbook' failed".

Clicking on Debug indicates this row as the issue:

Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum

Even with the "non" sheets which I was running just as a test, I'm still presented with dialog boxes during the save process - "The following features cannot be saved in macro-free workbooks: VB project..." - I don't really care because the separated saved files can just be regular xlsx; they're simply balance sheets to be distributed, edited and returned.

Here is the full code:

Sub SplitWorkbook()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "mm hh-mm-ss")
FolderName = xWb.Path & "\" & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
If xWs.Name Like "non*" Then
xWs.Copy
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub