Code to save each sheet in a work book as a separate file

cav~firez22

Well-known Member
Joined
Jun 21, 2006
Messages
543
Hello everyone,

Could someone help me with macro to save each sheet that is in a workbook, as its own file?

I have a book with x amount of sheets, and i want each sheet to be save to its own book, and named whatever the sheet name is. Is that do-able?

i would really apprecate any help on this one.

Thanks
 

Some videos you may like

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.

Tom Urtis

MrExcel MVP
Joined
Feb 10, 2002
Messages
11,224
Code:
Sub Test1()
Application.ScreenUpdating = False
Dim ws As Worksheet, strPath$, strSheetName$
strPath = ThisWorkbook.Path & "\"
For Each ws In Worksheets
strSheetName = ws.Name
Workbooks.Add 1
ws.Cells.Copy Cells
Sheets(1).Name = strSheetName
ActiveWorkbook.SaveAs strPath & strSheetName & ".xls"
Next
Application.ScreenUpdating = True
End Sub
 

cav~firez22

Well-known Member
Joined
Jun 21, 2006
Messages
543
Cool thanks.

how can I make it so it does all sheets, EXCEPT
"Actual" & Pcard Statement"

Also, would it be possible to, once each sheet is saved, Email to a person, based on the name of the sheet?

if i were to create a range and have it hidden with
name - email address

then could the macro decifer who to send the one file to?

any help with this is greatly apprecaited as normaly this task is about 8 hours to do.

thanx much
 

cav~firez22

Well-known Member
Joined
Jun 21, 2006
Messages
543
Code:
Sub Test1()
Application.ScreenUpdating = False
Dim ws As Worksheet, strPath$, strSheetName$
strPath = ThisWorkbook.Path & "\"
For Each ws In Worksheets
strSheetName = ws.Name
Workbooks.Add 1
ws.Cells.Copy Cells
Sheets(1).Name = strSheetName
ActiveWorkbook.SaveAs strPath & strSheetName & ".xls"
Next
Application.ScreenUpdating = True
End Sub

Ok, i ran this, where would i add code to close the newly saved book, before continueing to the next?

Also, instead of using the current directory, is there a way to have a dialog box, so the user can select the directory, and the following files will use that loacation?

Thanx much
 

Tom Urtis

MrExcel MVP
Joined
Feb 10, 2002
Messages
11,224
Ok, i ran this, where would i add code to close the newly saved book, before continueing to the next?

Also, instead of using the current directory, is there a way to have a dialog box, so the user can select the directory, and the following files will use that loacation?
Yes and Yes, with this in a new standard module:


Code:
Public Type BROWSfromFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowsfromfo As BROWSfromFO) As Long

Function GetDirectory(Optional Msg As String) As String
    Dim bInfo As BROWSfromFO
    Dim Path As String
    Dim r As Long, x As Long, pos As Integer
    bInfo.pidlRoot = 0&
    bInfo.lpszTitle = "Select your destination path:"
    bInfo.ulFlags = &H1
    x = SHBrowseForFolder(bInfo)
    Path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal Path)
    If r Then
        pos = InStr(Path, Chr$(0))
        GetDirectory = Left(Path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

Sub KoppySheetz()
   Dim strDir As String
   strDir = GetDirectory
   If strDir = "" Then
   MsgBox "You did not select a destination path.", 48, "Cancelled"
   Exit Sub
   End If
   
   If Left(strDir, 1) <> "\" Then strDir = strDir & "\"

With Application
.ScreenUpdating = False
.DisplayAlerts = False
Dim ws As Worksheet, strSheetName$
For Each ws In Worksheets
strSheetName = ws.Name
Workbooks.Add 1
ws.Cells.Copy Cells
Sheets(1).Name = strSheetName
ActiveWorkbook.SaveAs strDir & strSheetName & ".xls"
ActiveWorkbook.Close 0
Next
.DisplayAlerts = True
.ScreenUpdating = True
End With

MsgBox "Your sheets are individually saved in the path" & vbCrLf & _
strDir, 64, "Done"

End Sub
 

galileogali

Well-known Member
Joined
Oct 14, 2005
Messages
748
Tom
can you to see this code?

Rich (BB code):
Sub Test1()
Application.ScreenUpdating = False
Dim ws As Worksheet, strPath$, strSheetName$
strPath = ThisWorkbook.Path & "\"
For Each ws In Worksheets
strSheetName = ws.Name
ws.Copy
ActiveSheet.Parent.SaveAs strPath & strSheetName & ".xls"
Next
Application.ScreenUpdating = True
End Sub

GALILEOGALI
 

Watch MrExcel Video

Forum statistics

Threads
1,122,715
Messages
5,597,726
Members
414,169
Latest member
Preston_Cleric

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top