PDA

View Full Version : Work Books Sheets copy to Multiple WorkBooks and Rename and Save



nrk
01-13-2019, 11:24 PM
I have workbook and there many sheets i want to copy one by one sheets to new work book and rename workbook and save except first sheet
I tried many times, but it saved in one workbook instead of separate workbooks
Option Explicit

Sub CreateWorkBooks()
Dim ws As Object
Dim i As Long
Dim ws_num As Integer
Application.ScreenUpdating = False

Set ws = Worksheets
ws_num = ThisWorkbook.Worksheets.Count

For i = 2 To ws_num
'Copy one worksheet as a new workbook
'The new workbook becomes the ActiveWorkbook
ws.Copy

'Replace all formulas with values (optional)
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value

'May want (not required) to add a file name extension (.xls or .xlsx) to the file name
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & _
"AR Balance- " & ActiveSheet.Name & " " & Worksheets("DATA Sheet").Range("m2") & ".xlsx"
ActiveWorkbook.Close SaveChanges:=False
Next

Application.ScreenUpdating = True
End Sub

Paul_Hossler
01-14-2019, 08:03 AM
I'd do something like this

I don't like to rely on sheet numbers (e.g. 'the 'first sheet') being what I think they are -- safer to use .Name

Added deleting output workbooks if they already exist




Option Explicit
Sub CreateWorkBooks()
Dim ws As Worksheet
Dim wb1 As Workbook, wb2 As Workbook
Dim sFilename As String, sM2 As String

Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
sM2 = wb1.Worksheets("DATA").Range("M2")

For Each ws In wb1.Worksheets

If ws.Name = "DATA" Then GoTo GetNext

'Copy one worksheet as a new workbook
'The new workbook becomes the ActiveWorkbook
ws.Copy

Set wb2 = ActiveWorkbook

'Replace all formulas with values (optional)
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value

'May want (not required) to add a file name extension (.xls or .xlsx) to the file name
sFilename = wb1.Path & "\" & "AR Balance- " & ActiveSheet.Name & " " & sM2 & ".xlsx"

On Error Resume Next
Application.DisplayAlerts = False
Kill sFilename
Application.DisplayAlerts = True
On Error GoTo 0


wb2.SaveAs sFilename, xlOpenXMLWorkbook
wb2.Close SaveChanges:=False

wb1.Activate
GetNext:
Next
Application.ScreenUpdating = True
End Sub