VBA 2010 Saving workshts-workbks new file Closed

Question

Hiya, 

I've found a fabulous bit of code that saves the individual worksheets as individual workbooks. It works brilliantly and I'm just wondering if there is a way to tweek it to do one more thing. Here's the code:


'Saving Individual worksheets as 97-2003 workbooks
 
Dim NewBook As Workbook, OldBook As Workbook, sh As Worksheet
     
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
     
     
    Set OldBook = Workbooks(ActiveWorkbook.Name)
    
    Application.DisplayAlerts = False
   
    For Each sh In OldBook.Worksheets
        If sh.Visible = True Then
            sh.Copy
            ActiveWorkbook.SaveAs Filename:=OldBook.Path & "\" & sh.Name & "", FileFormat:=xlWorkbookNormal
            ActiveWorkbook.Close
            
            
        End If
    Next
     
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    Application.DisplayAlerts = True

There are a few worksheets that I would like to be saved to a specific folder which I need to create called 'Printed'. I'm wondering if the above code can be adapted to create that new folder and save these specific workbooks to that folder. Or perhaps rather than adapting this code it might be easier to write a code to create the the new folder and move the specified files after they've been saved by the above macro...?

rizvisa1 · Answer

How would one can say what sheet goes where. Presuming you know where, here is a sample code. The code would make use of a function MakeMultiStepDirectory. See the comments. You would have to download from there as no reason to reinvent the wheel 
In the code below, idea is  


Sub test() 
   'Saving Individual worksheets as 97-2003 workbooks 
    
   Dim NewBook             As Workbook 
   Dim OldBook             As Workbook 
   Dim sh                  As Worksheet 
   Dim sPrintPath          As String 
   Dim sOldPath            As String 
   Dim sSavePath           As String 
    
   Application.ScreenUpdating = False 
   Application.Calculation = xlCalculationManual 
    
   Set OldBook = Workbooks(ActiveWorkbook.Name) 
   sOldPath = OldBook.Path 
    
   sPrintPath = sOldPath & "\print\" 
    
   'the MakeMultiStepDirectory function can be found at (fix spaces) 
   'htt p: / / ww w.cpearson.com/excel/MakeDirMulti.aspx 
   Call MakeMultiStepDirectory(sPrintPath) 

   Application.DisplayAlerts = False 
    
   For Each sh In OldBook.Worksheets 
      If sh.Visible = True _ 
      Then 
         Select Case sh.Name 
            Case "Sheet1", "Sheet2", "Sheet3" 
               sSavePath = sPrintPath 
            Case Else 
               sSavePath = sOldPath 
         End Select 
         sh.Copy 
         ActiveWorkbook.SaveAs Filename:=sSavePath & "\" & sh.Name & "", FileFormat:=xlWorkbookNormal 
         ActiveWorkbook.Close 
      End If 
   Next 
    
   Application.ScreenUpdating = True 
   Application.Calculation = xlCalculationAutomatic 
    
   Application.DisplayAlerts = True 

End Sub

VBA 2010 Saving workshts-workbks new file

1 response

Similar discussions

Subscribe To Our Newsletter!