Copy Multiple Worksheets to New Folders

[VBAAccountant]

Hello,

I have an excel file with multiple sheets (Ex: Santa, Rudolf, Dasher, etc) in my Current folder. I need to create a macro that will copy those sheets into seperate existing folders with the same names (Santa, Rudolf, Dasher, etc) in another network folder path.

I have this macro that copies the sheets and saves them as separate files (which I want), but they are all going in the a new folder together. I'm not sure how to get them to be saved individually in the existing folders with the corresponding names:

Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 5 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub

Any suggestions would be greatly appreciated : )

 

[Herakles]

Does this work?

It creates the subfolders if they don't already exist.

I'm glad to see that you are working hard to make sure that children get their presents this Christmas.

Sub SaveShtsAsBook()
Dim i As Integer
Dim strPath As String
Dim Wb As Workbook

   ActiveWorkbook.Save
   
   Application.ScreenUpdating = False
   
   ' Set an object to the master workbook.
    Set Wb = ThisWorkbook
   
    strPath = Wb.Path & "\" & Left(Wb.Name, Len(Wb.Name) - 5)
      
    If Dir(strPath, vbDirectory) = "" Then
        MkDir strPath
    End If
   
    For i = 5 To Wb.Sheets.Count
           
        If Dir(strPath & "\" & Sheets(i).Name, vbDirectory) = "" Then
            MkDir strPath & "\" & Wb.Sheets(i).Name
        End If
          
        Wb.Sheets(i).Copy
                
        ActiveWorkbook.SaveAs strPath & "\" & Wb.Sheets(i).Name & "\" & Wb.Sheets(i).Name & ".xlsx"
        
        ActiveWorkbook.Close
      
    Next i
    
    Application.ScreenUpdating = True
    
    ActiveWorkbook.Save
    
    MsgBox "Worksheets copied and saved in correspondingly named workbooks.", vbOKOnly, "Confirmation"
    
End Sub

 

[VBAAccountant]

Thanks LOL. I'll try that now.

 

[VBAAccountant]

Does this work?

It creates the subfolders if they don't already exist.

I'm glad to see that you are working hard to make sure that children get their presents this Christmas.

Sub SaveShtsAsBook()
Dim i As Integer
Dim strPath As String
Dim Wb As Workbook

   ActiveWorkbook.Save
  
   Application.ScreenUpdating = False
  
   ' Set an object to the master workbook.
    Set Wb = ThisWorkbook
  
    strPath = Wb.Path & "\" & Left(Wb.Name, Len(Wb.Name) - 5)
     
    If Dir(strPath, vbDirectory) = "" Then
        MkDir strPath
    End If
  
    For i = 5 To Wb.Sheets.Count
          
        If Dir(strPath & "\" & Sheets(i).Name, vbDirectory) = "" Then
            MkDir strPath & "\" & Wb.Sheets(i).Name
        End If
         
        Wb.Sheets(i).Copy
               
        ActiveWorkbook.SaveAs strPath & "\" & Wb.Sheets(i).Name & "\" & Wb.Sheets(i).Name & ".xlsx"
       
        ActiveWorkbook.Close
     
    Next i
   
    Application.ScreenUpdating = True
   
    ActiveWorkbook.Save
   
    MsgBox "Worksheets copied and saved in correspondingly named workbooks.", vbOKOnly, "Confirmation"
   
End Sub

Works perfectly...thank you!