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

[cav~firez22]

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

 

[Tom Urtis]

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]

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]

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]

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:

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]

Tom
can you to see this 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