Copy Sheets to Separate Workbooks
Use with caution because files will be overwritten without asking.
Option Explicit
Sub CopySheetToNewWorkbook()
Const MyPath As String = "MyPath" ' Sub Folder Name of This Workbook's Path
Dim ws As Worksheet ' First Worksheet
Dim i As Long ' Sheets Counter
Dim SavePath As String ' Save Path
Dim SaveFullName As String ' Save Full Name
With ThisWorkbook
Set ws = .ActiveSheet
SavePath = .Path & Application.PathSeparator & MyPath _
& Application.PathSeparator
Application.ScreenUpdating = False
For i = ws.Index To .Sheets.Count
With .Sheets(i)
SaveFullName = SavePath & .Name & ".xls"
.Copy
End With
GoSub SaveAndClose
Next i
Application.ScreenUpdating = True
End With
MsgBox "Copied sheets to new workbooks.", vbInformation, _
"New Workbooks Saved and Closed"
GoTo exitProcedure
' Save and close new workbook.
SaveAndClose:
On Error GoTo NewWorkbookError ' e.g. if workbook with same name is open.
With ActiveWorkbook
' Note: The two Application.DisplayAlerts lines prevent Excel
' complaining about e.g.:
' Overwrite if file exists.
' Save if data outside of FileFormat (Compatibility Checker).
Application.DisplayAlerts = False
.SaveAs SaveFullName, FileFormat:=xlExcel8
Application.DisplayAlerts = True
.Close False ' Close but do not save.
End With
On Error GoTo 0
Return
NewWorkbookError:
ActiveWorkbook.Close False ' Close but do not save.
MsgBox Err.Description, vbExclamation, "New Workbook Closed and Not Saved"
Resume exitProcedure
exitProcedure:
End Sub
Copy Sheets to Single Workbook
I developed this code first assuming (misreading the post) that the ActiveSheet had some kind of date in its name.
Use with caution because files will be overwritten without asking.
Sub CopySheetsToNewWorkbook()
Const MyPath As String = "MyPath" ' Sub Folder Name of This Workbook's Path
Dim ws As Worksheet ' First Worksheet
Dim SheetsGroup() As String ' Sheets Group Array
Dim SheetsDiff As Long ' Sheets Difference
Dim i As Long ' Sheets Array Elements (Columns) Counter
Dim SavePath As String ' Save Path
Dim SaveName As String ' Save Name
' Copy sheets from this workbook to new workbook.
With ThisWorkbook
' Define First Worksheet, Save Name and Save Path.
Set ws = .ActiveSheet
SaveName = ws.Name & ".xls"
SavePath = .Path & Application.PathSeparator & MyPath _
& Application.PathSeparator & SaveName
' Write sheet names to Sheets Group Array.
ReDim SheetsGroup(.Sheets.Count - ws.Index)
SheetsDiff = .Sheets.Count - ws.Index
For i = 0 To SheetsDiff
SheetsGroup(i) = .Worksheets(i + SheetsDiff - 1).Name
Next i
' Copy sheets from Sheets Group Array to new workbook (ActiveWorkbook).
.Sheets(SheetsGroup).Copy
End With
' Save and close New Workbook.
On Error GoTo NewWorkbookError ' e.g. if workbook with same name is open.
With ActiveWorkbook
' Note: The two Application.DisplayAlerts lines prevent Excel
' from complaining about e.g.:
' Overwrite if file exists.
' Save if data outside of FileFormat (Compatibility Checker).
Application.DisplayAlerts = False
.SaveAs SavePath, FileFormat:=xlExcel8
Application.DisplayAlerts = True
.Close False ' Close but do not save.
End With
On Error GoTo 0
MsgBox "Copied sheets to new workbook.", vbInformation, _
"New Workbook Saved and Closed"
GoTo exitProcedure
NewWorkbookError:
ActiveWorkbook.Close False ' Close but do not save.
MsgBox Err.Description, vbExclamation, "New Workbook Closed and Not Saved"
Resume exitProcedure
exitProcedure:
End Sub
Close Workbooks
A few times I had over ten workbooks open while developing the previous code, so I wrote this little time saver.
Use it with caution because workbooks will be closed without saving changes.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Closes all workbooks except this one (ThisWorkbook). '
' Remarks: Be careful because all the changes on those other workbooks '
' will be lost. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub closeWorkbooks()
Dim wb As Workbook
Application.ScreenUpdating = False
For Each wb In Workbooks
If Not wb Is ThisWorkbook Then wb.Close False
Next wb
Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
