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

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

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

Code:

---


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

---

Quote:

---

Originally Posted by 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

Code:

---


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.

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?

Quote:

---

Originally Posted by 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?

---

yes! exactly.

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

thank you very much :)))

OK -- try this

Code:

---

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

---

Quote:

---

Originally Posted by Paul_Hossler

OK -- try this

Code:

---

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

Quote:

---

Originally Posted by Paul_Hossler

OK -- try this

Code:

---

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?

Change this line

Code:

---

sPath1 = wb1.Path & Application.PathSeparator

---

to

Code:

---

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

---

Quote:

---

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

Attachment 21584

2. Draw a box

3. Assign the macro to it
Attachment 21585