• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

How to save each tab into a different folder?

JoelPop

New Member
In the past I was using the attached VBA to separate each tab into its own workbook and was saving it to one file path (referenced in one of my sheets) and then dragging each file to its proper folder. So is there a way from me to save each new workbook based on its name to a specific folder. I have all of the references file paths layout in one of my sheets like I was doing befor but, I’m unsure how to get this to work with 40 different sheets?

Code:
Sub ExportWeekly()

myOrigWkb = ActiveWorkbook.Name
Sheets("Directions").Select

myFilePath = Range("A17").Value
myPeriod = Range("A20").Value


For Each shtnext In Sheets
  shtnext.Activate
  If Right(ActiveSheet.Name, 6) = "Review" Then

  ActiveSheet.Select
  ActiveSheet.Copy
 
 
  Rows("8:8").Select
  Range(Selection, Selection.End(xlDown)).Select
  Rows("8:331").EntireRow.AutoFit
  Range("F8").Activate
 
 
  mySubject = Range("C6").Value
  myLocNum = Range("B1").Value
  myLoc = Range("B2").Value
 
'Save File


  myFileName = myFilePath & mySubject & " " & myDate & ".xlsx"
 
  Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs Filename:=myFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  ActiveWorkbook.Close
  Application.DisplayAlerts = False
 
 
 
  Workbooks(myOrigWkb).Activate
 
  Sheets("Directions").Activate
 
 
 
 
  End If
Next shtnext

End Sub
 
Last edited by a moderator:
I use this code to split each sheet to workbook and then save to folder with same name. You will want to have the workbook with the code in the folder where all sub-folders will be located.

You can modify the code to reference cell for path and/or folder as needed.
Code:
Sub Splitbook()
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
    xWs.Copy
    If Not DirExists(xPath & "\" & xWs.Name) Then
        MkDir (xPath & "\" & xWs.Name)
        Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & "\" & xWs.Name & ".xlsx"
        Application.ActiveWorkbook.Close False
    Else
        Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & "\" & xWs.Name & ".xlsx"
        Application.ActiveWorkbook.Close False
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function DirExists(DirName As String) As Boolean
    On Error GoTo ErrorHandler
    DirExists = GetAttr(DirName) And vbDirectory
ErrorHandler:
End Function

Code is combination of codes found in links:
http://www.vbaexpress.com/forum/showthread.php?7866-Check-for-folder-create-if-it-does-not-exist
http://www.extendoffice.com/documents/excel/628-excel-split-workbook.html
 
Back
Top