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

21584

2. Draw a box

3. Assign the macro to it
21585