VBA to Separate a Workbook into Several Workbooks

[Graemea]

Hi,


I have a workbook consisting of a large number of worksheets that I'd like to separate, using VBA code, into a number of smaller workbooks, with the criterion used to separate the sheets being the date in cell A6 of each sheet.


Each sheet has a date in cell A6 in the text format "DD/MM/YYYY to DD/MM/YYYY".


Can someone please offer me some guidance about the VBA code that will use the first part of the text in cell A6 of each sheet to separate the large workbook into several smaller ones.


For example, all worksheets with "31/10/2017" in cell A6 (e.g. "31/10/2017 to 31/08/2018") will be copied to a new workbook, all worksheets with "30/11/2017" as the first date in cell A6 (e.g. "30/11/2017 to 31/08/2018") will be copied to another workbook etc.


Thanks!

 

[SpillerBD]

This could be a start. It copies each selected sheet to a new Workbook.
An array of qualified sheets would be needed, so you end up running through all the sheets once before then creating the new workbooks.
You will also want to change how the file name is determined for the new Workbooks.

'SpltSheets
Sub SplitSelectedWorkSheets()
    Dim ws As Worksheet
    Dim DisplayStatusBar As Boolean
    Dim DestinationPath As Variant
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Select a destination folder or create a new destination."
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "Cancelled"
            Exit Sub
        Else
            'MsgBox .SelectedItems(1)
            DestinationPath = .SelectedItems(1)
        End If
    End With
    
    DisplayStatusBar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = ActiveWindow.SelectedSheets.Count & " Remaining Sheets"
    
    For Each ws In ActiveWindow.SelectedSheets
        Dim NewFileName As String
       
        'Macro-Enabled
        'NewFileName = ThisWorkbook.Path & "\" & ws.Name & ".xlsm"
        'Not Macro-Enabled
            NewFileName = DestinationPath & "\" & ws.Name & ".xlsx"
            ws.Copy
            'ActiveWorkbook.Sheets(1).Name = "Sheet1"
            'ActiveWorkbook.SaveAs Filename:=NewFileName, _
                FileFormat:=xlOpenXMLWorkbookMacroEnabled
            ActiveWorkbook.SaveAs fileName:=NewFileName, _
                FileFormat:=xlOpenXMLWorkbook
            ActiveWorkbook.Close SaveChanges:=False

    Next
    
    Application.DisplayAlerts = True
    Application.StatusBar = False
    Application.DisplayStatusBar = DisplayStatusBar
    Application.ScreenUpdating = True
    Close 'close all files and folders?
End Sub

 

[Graemea]

Thank you!