Split workbook into worksheets

[Chaverim]

Hi,
I have got an Excel workbook with a few sheets in. I would like to split the workbook so that each separate sheet is transferred to a new workbook using VBA (in other words, split a workbook into many workbooks) and I would like to be able to choose where to save the new workbooks when the macro is running (meaning, open the save as dialogue).

Please advise me what to do.

Many thanks.

 

[ranman256]

paste this code into a module (developer vbe area, insert, modules)
then run macro: ExportAllSheets2Nam

'----------------
Public Sub ExportAllSheets2Name()
'----------------
Dim sht, vFile, vDir

vDir = getMyDocs()
For Each sht In Worksheets
     'MsgBox sht.Name
    vFile = UserFileSaveAs(vDir, sht.Name)
    If vFile = "" Then Exit Sub
    vDir = getDirName(vFile)
    
    sht.Copy
    ActiveWorkbook.SaveAs Filename:=vFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.Close False
    
Next
End Sub

'----------------
Public Function UserFileSaveAs(ByVal pvPath, ByVal pvName)
'----------------
Dim strTable As String
Dim strFilePath As String
Dim sDialog As String, sDecr  As String, sExt As String


                                'MUST ADD REFERENCE : Microsoft Office 11.0 Object Library
With Application.FileDialog(msoFileDialogSaveAs)
'With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    .Title = "Save sheet:" & UCase(pvName)
    .ButtonName = "Save"
    '.Filters.Clear
    '.Filters.Add "All Files", "*.*"
    .InitialFileName = pvPath
    .InitialView = msoFileDialogViewList    'msoFileDialogViewThumbnail
    ''.AllowMultiSelect = True
     
        If .Show = 0 Then
           'There is a problem
           Exit Function
        End If
    
    'Save the first file selected
    UserFileSaveAs = Trim(.SelectedItems(1))
End With
End Function


'----------------
Public Function getMyDocs()
'----------------
Dim vDir, vUsr

On Error GoTo errDocs
vUsr = Environ("UserProfile")
vDir = vUsr & "\Documents\"
If Not DirExists(vDir) Then
    vDir = vUsr & "\My Documents\"
    If Not DirExists(vDir) Then
       vDir = "c:\temp"
       MakeDir vDir
    End If
End If
getMyDocs = vDir
Exit Function
errDocs:
MsgBox "Cannot find temp folder", vbInformation, "getMyDocs():" & Err
End Function

'----------------
Public Function getDirName(ByVal psFilePath)
'----------------
Dim i As Integer, sDir As String

i = InStrRev(psFilePath, "\")
If i > 0 Then getDirName = Left(psFilePath, i)
End Function

 

[Chaverim]

Thanks. The code didn't work, it said that there was a problem with [DirExist] within the Public Function getMyDocs!

 

[ranman256]

oops, i forgot it, sorry:

Public Function DirExists(ByVal pvDir) As Boolean
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
DirExists = FSO.FolderExists(pvDir)
Set FSO = Nothing
End Function

 

[Jon von der Heyden]

Hi Chaverim

As you can see from reactions to your cross-post here, cross-posting isn't exactly good netiquette. That's because members get frustrated when they make contributions without knowing that you are already enlisting help elsewhere, and possibly have a solution to the problem.

If you are going to cross-post, please ensure that you post the links back to the cross-posts in your thread here so that members may see what suggestion have already been offered.

 

[Macropod]

Cross-posted at: http://www.msofficeforums.com/excel-programming/37421-split-workbook-into-worksheets.html
Please read Mr Excel's policy on Cross-Posting in rule 13: http://www.mrexcel.com/forum/board-announcements/99490-forum-rules.html

 

[Chaverim]

Link 1: http://www.msofficeforums.com/excel-programming/37421-split-workbook-into-worksheets.html
Link 2: https://www.excelforum.com/excel-pr...lit-workbook-into-worksheets.html#post4788850