loop for Exporting worksheets to a new workbook

[rakesh933]

Hi All,

i have a workbook with multiple worksheets, except for "Sheet1" i want all the other sheet to be moved as individual new workbooks (with same name as the worksheet i.e new workbook name = worksheet name + current date)

For ex : i have sheet named : sheet1, apple, samsung,HTC.

i need to move individual worksheets (except sheet1) to create individual workbooks

Please help.

Thanks
Rakesh

 

[BrianMH]

'change this constant to the path you want to save to.  Make sure it ends with \

Public Const sPath As String = "C:\Temp\"


Sub CopySheetsToNewBook()
    Dim sSavePath As String
    Dim ws As Worksheet
    Dim wbCopy As Workbook
    Dim wsCopy As Worksheet
    Dim wbTo As Workbook
    Set wbCopy = ThisWorkbook
    Dim wsDel As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Sheet1" Then    'change the name of this sheet to exclude whatever sheet name you want
            sSavePath = sPath & ws.Name & Format(Date, "YYYYMMDD")
            Set wbTo = Workbooks.Add
            On Error Resume Next
            Set wsDel = wbTo.Sheets(ws.Name)
            On Error GoTo 0
            If Not wsDel Is Nothing Then wsDel.Delete
            Set wsDel = Nothing
            ws.Copy wbTo.Sheets(1)
            wbTo.SaveAs sSavePath
            wbTo.Close
        End If




    Next ws
End Sub

 

[Norie]

Try this.

Dim wb As Workbook
Dim ws As Worksheet
Dim strPath As String

    strPath = ActiveWorkbook.Path

    For Each ws In ActiveWorkbook.Sheets
        If ws.Name<>"Sheet1" Then
            ws.Copy
            Set wbNew = ActiveWorkbook
            wbNew.SaveAs FileName:= strPath & Application.PathSeparator & ws.Name & Date & ".xlsx
            wbNew.Close False ' optional
        End If
    Next ws

 

[rakesh933]

Try this.

Dim wb As Workbook
Dim ws As Worksheet
Dim strPath As String

    strPath = ActiveWorkbook.Path

    For Each ws In ActiveWorkbook.Sheets
        If ws.Name<>"Sheet1" Then
            ws.Copy
            Set wbNew = ActiveWorkbook
            wbNew.SaveAs FileName:= strPath & Application.PathSeparator & ws.Name & Date & ".xlsx
            wbNew.Close False ' optional
        End If
    Next ws

Thanks much works like a charm ! just one thing though , how to i change the path ? say i wanna save all the files to "C:\Temp" ?

 

[BrianMH]

Change

strPath = ActiveWorkbook.Path

to

strPath = "C:\Temp"