it is possible to save individual sheets as a separate file?

[Aihmar]

I have 12 sheets each of departments and sub-departments.
I want to save them as a separate file for monthly report.

sample:

january 2018 and so on...

and the original will blank for the next month's report

thank you very much in advance.

god bless

[Paul_Hossler]

Didn't understand some of what you wanted, but this should be a start

It puts the output workbooks in the same folder, and give them the previous month's as a file name

Option Explicit
Sub SplitWorkbook()
    Dim sDate As String
    Dim ws As Worksheet
    Dim wb1 As Workbook, wb2 As Workbook
    Dim sPath1 As String, sFile2 As String
    
    Application.ScreenUpdating = False
    
    Set wb1 = ThisWorkbook
    
    If Month(Now) - 1 = 0 Then
        sDate = Format(DateSerial(Year(Now) - 1, 12, 1), "mmmm yyyy")
    Else
        sDate = Format(DateSerial(Year(Now), Month(Now) - 1, 1), "mmmm yyyy")
    End If
        
        
    sPath1 = wb1.Path & Application.PathSeparator
        
    For Each ws In wb1.Worksheets
        sFile2 = sDate & " " & ws.Name
        ws.Copy
        Set wb2 = ActiveWorkbook
        
        On Error Resume Next
        Kill sPath1 & sFile2 & ".xlsx"
        On Error GoTo 0
        
        wb2.SaveAs Filename:=sPath1 & sFile2, FileFormat:=xlOpenXMLWorkbook
    
        wb2.Close (False)
    
        wb1.Activate
    
    Next
    Application.ScreenUpdating = True
End Sub

[Aihmar]

Didn't understand some of what you wanted, but this should be a start

It puts the output workbooks in the same folder, and give them the previous month's as a file name

Option Explicit
Sub SplitWorkbook()
    Dim sDate As String
    Dim ws As Worksheet
    Dim wb1 As Workbook, wb2 As Workbook
    Dim sPath1 As String, sFile2 As String
    
    Application.ScreenUpdating = False
    
    Set wb1 = ThisWorkbook
    
    If Month(Now) - 1 = 0 Then
        sDate = Format(DateSerial(Year(Now) - 1, 12, 1), "mmmm yyyy")
    Else
        sDate = Format(DateSerial(Year(Now), Month(Now) - 1, 1), "mmmm yyyy")
    End If
        
        
    sPath1 = wb1.Path & Application.PathSeparator
        
    For Each ws In wb1.Worksheets
        sFile2 = sDate & " " & ws.Name
        ws.Copy
        Set wb2 = ActiveWorkbook
        
        On Error Resume Next
        Kill sPath1 & sFile2 & ".xlsx"
        On Error GoTo 0
        
        wb2.SaveAs Filename:=sPath1 & sFile2, FileFormat:=xlOpenXMLWorkbook
    
        wb2.Close (False)
    
        wb1.Activate
    
    Next
    Application.ScreenUpdating = True
End Sub

I attached the file.

thank you very much.


how about the next month and so on?

can I call it with the command button?

I have a useform inputs data and click the corresponding button to send it to the corresponding sheets
and save it as other files the original workbook will be clear again for the next month's computation.

and the individually save sheets will serve as reports and months computation.

[Paul_Hossler]

Do you mean you want the sheets COLD STORAGE, FINANCE, ..., WAREHOUSE each copied to a separate workbook and then saved with a name like January 2018 COLD STORAGE.xlsx?

The first macro generates a name from the previous month and the sheet name

Since this is February, the names start with January 2018 ....

If you don't want that, how do you want the time stamp generated, or do you want to enter it?

[Aihmar]

Do you mean you want the sheets COLD STORAGE, FINANCE, ..., WAREHOUSE each copied to a separate workbook and then saved with a name like January 2018 COLD STORAGE.xlsx?

The first macro generates a name from the previous month and the sheet name

Since this is February, the names start with January 2018...

If you don't want that, how do you want the time stamp generated, or do you want to enter it?

yes! exactly.

its ok not to start in January. the start febuary2018 will be just very fine

thank you very much ))

[Paul_Hossler]

OK -- try this

Option Explicit
Sub SplitWorkbook()
    Dim sDate As String, sPrefix As String
    Dim wb1 As Workbook, wb2 As Workbook
    Dim sPath1 As String, sFile2 As String
    Dim i As Long
    Dim aSheetsToCopy As Variant, v As Variant
    
    'get default prefix -- Previous month + Year
    If Month(Now) - 1 = 0 Then
        sDate = Format(DateSerial(Year(Now) - 1, 12, 1), "mmmm yyyy")
    Else
        sDate = Format(DateSerial(Year(Now), Month(Now) - 1, 1), "mmmm yyyy")
    End If
    
    'see if the user wants to change it
    sPrefix = Application.InputBox("Enter the Prefix for the created workbooks, (blank) to exit", "Split Workbook", sDate, , , , , 2)
    
    'trim and if len = 0 then exit sub
    sPrefix = Trim(sPrefix)
    If Len(sPrefix) = 0 Then Exit Sub
    
    
    Application.ScreenUpdating = False
    
    'build list of sheets to extract
    aSheetsToCopy = Array("MAINTENANCE", "PRODUCTION", "PURCHASING", "QC", "SALES", "SHOWROOM", "WAREHOUSE", "COLD STORAGE", "FINANCE", "HR", "LADIES")
    
    'remember this workbook and path so we don't get confused
    Set wb1 = ThisWorkbook
    sPath1 = wb1.Path & Application.PathSeparator
    
    For Each v In aSheetsToCopy
    
        'make sure the sheet exists
        i = -1
        On Error Resume Next
        i = wb1.Worksheets(v).Index
        On Error GoTo 0
    
        If i = -1 Then
            Call MsgBox("Worksheet " & v & " does not exist", vbCritical + vbOKOnly, "Split Workbook")
            
        Else
            Application.StatusBar = "Copying " & v
            sFile2 = sPrefix & " " & v
            Worksheets(v).Copy
            Set wb2 = ActiveWorkbook
            
            On Error Resume Next
            Kill sPath1 & sFile2 & ".xlsx"
            On Error GoTo 0
            
            wb2.SaveAs Filename:=sPath1 & sFile2, FileFormat:=xlOpenXMLWorkbook
            
            wb2.Close (False)
            
            wb1.Activate
        End If
    Next
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
    Call MsgBox("Worksheets have been copied to seperate workbooks", vbInformation + vbOKOnly, "Split Workbook")
    
    
End Sub

[Aihmar]

OK -- try this

Option Explicit
Sub SplitWorkbook()
    Dim sDate As String, sPrefix As String
    Dim wb1 As Workbook, wb2 As Workbook
    Dim sPath1 As String, sFile2 As String
    Dim i As Long
    Dim aSheetsToCopy As Variant, v As Variant
    
    'get default prefix -- Previous month + Year
    If Month(Now) - 1 = 0 Then
        sDate = Format(DateSerial(Year(Now) - 1, 12, 1), "mmmm yyyy")
    Else
        sDate = Format(DateSerial(Year(Now), Month(Now) - 1, 1), "mmmm yyyy")
    End If
    
    'see if the user wants to change it
    sPrefix = Application.InputBox("Enter the Prefix for the created workbooks, (blank) to exit", "Split Workbook", sDate, , , , , 2)
    
    'trim and if len = 0 then exit sub
    sPrefix = Trim(sPrefix)
    If Len(sPrefix) = 0 Then Exit Sub
    
    
    Application.ScreenUpdating = False
    
    'build list of sheets to extract
    aSheetsToCopy = Array("MAINTENANCE", "PRODUCTION", "PURCHASING", "QC", "SALES", "SHOWROOM", "WAREHOUSE", "COLD STORAGE", "FINANCE", "HR", "LADIES")
    
    'remember this workbook and path so we don't get confused
    Set wb1 = ThisWorkbook
    sPath1 = wb1.Path & Application.PathSeparator
    
    For Each v In aSheetsToCopy
    
        'make sure the sheet exists
        i = -1
        On Error Resume Next
        i = wb1.Worksheets(v).Index
        On Error GoTo 0
    
        If i = -1 Then
            Call MsgBox("Worksheet " & v & " does not exist", vbCritical + vbOKOnly, "Split Workbook")
            
        Else
            Application.StatusBar = "Copying " & v
            sFile2 = sPrefix & " " & v
            Worksheets(v).Copy
            Set wb2 = ActiveWorkbook
            
            On Error Resume Next
            Kill sPath1 & sFile2 & ".xlsx"
            On Error GoTo 0
            
            wb2.SaveAs Filename:=sPath1 & sFile2, FileFormat:=xlOpenXMLWorkbook
            
            wb2.Close (False)
            
            wb1.Activate
        End If
    Next
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
    Call MsgBox("Worksheets have been copied to seperate workbooks", vbInformation + vbOKOnly, "Split Workbook")
    
    
End Sub

Can I call this in command button?
thank you very much, Paul

[Aihmar]

OK -- try this

Option Explicit
Sub SplitWorkbook()
    Dim sDate As String, sPrefix As String
    Dim wb1 As Workbook, wb2 As Workbook
    Dim sPath1 As String, sFile2 As String
    Dim i As Long
    Dim aSheetsToCopy As Variant, v As Variant
    
    'get default prefix -- Previous month + Year
    If Month(Now) - 1 = 0 Then
        sDate = Format(DateSerial(Year(Now) - 1, 12, 1), "mmmm yyyy")
    Else
        sDate = Format(DateSerial(Year(Now), Month(Now) - 1, 1), "mmmm yyyy")
    End If
    
    'see if the user wants to change it
    sPrefix = Application.InputBox("Enter the Prefix for the created workbooks, (blank) to exit", "Split Workbook", sDate, , , , , 2)
    
    'trim and if len = 0 then exit sub
    sPrefix = Trim(sPrefix)
    If Len(sPrefix) = 0 Then Exit Sub
    
    
    Application.ScreenUpdating = False
    
    'build list of sheets to extract
    aSheetsToCopy = Array("MAINTENANCE", "PRODUCTION", "PURCHASING", "QC", "SALES", "SHOWROOM", "WAREHOUSE", "COLD STORAGE", "FINANCE", "HR", "LADIES")
    
    'remember this workbook and path so we don't get confused
    Set wb1 = ThisWorkbook
    sPath1 = wb1.Path & Application.PathSeparator
    
    For Each v In aSheetsToCopy
    
        'make sure the sheet exists
        i = -1
        On Error Resume Next
        i = wb1.Worksheets(v).Index
        On Error GoTo 0
    
        If i = -1 Then
            Call MsgBox("Worksheet " & v & " does not exist", vbCritical + vbOKOnly, "Split Workbook")
            
        Else
            Application.StatusBar = "Copying " & v
            sFile2 = sPrefix & " " & v
            Worksheets(v).Copy
            Set wb2 = ActiveWorkbook
            
            On Error Resume Next
            Kill sPath1 & sFile2 & ".xlsx"
            On Error GoTo 0
            
            wb2.SaveAs Filename:=sPath1 & sFile2, FileFormat:=xlOpenXMLWorkbook
            
            wb2.Close (False)
            
            wb1.Activate
        End If
    Next
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
    Call MsgBox("Worksheets have been copied to seperate workbooks", vbInformation + vbOKOnly, "Split Workbook")
    
    
End Sub

how can I change file save location?

[Paul_Hossler]

Change this line

 sPath1 = wb1.Path & Application.PathSeparator

to

 sPath1 = "C:\Users\MyName\Desktp\etc" & Application.PathSeparator

[Paul_Hossler]

Can I call this in command button?
thank you very much, Paul

Yes

1. Use the Developer tab, and insert a control -- I'd use a Form Control

Capture.JPG

2. Draw a box

3. Assign the macro to it
Capture2.JPG