Save sheets in different folders

[sweeneytime]

Hi Guys,

I have been trying to adapt code I have already but with no success.

I want to save all sheets in a workbook that have "project reports" in A3.
Use the file path in D2, each sheet has a different file path.

Sub SelectAll()
    Dim ws As Worksheet
    Dim bStarted As Boolean
 
 
 
    For Each ws In ActiveWorkbook.Worksheets
            If ws.Range("A3").Text = ("Project Reports") Then
                Call SaveSheets
            End If
    Next ws
 
 
End Sub
 
Sub SaveSheets()
   Dim iSheet As Integer
   Dim sPath As String
   Application.ScreenUpdating = False
   sPath = Range("D2").Value & "\"
 
      ActiveWorkbook.SaveAs sPath & ActiveSheet.Name
      ActiveWorkbook.Close savechanges:=False
 
   Application.ScreenUpdating = True
 
End Sub

The second part of the code was adapted from this.

Sub SaveSheets1()
   Dim iSheet As Integer
   Dim sPath As String
   Application.ScreenUpdating = False
   sPath = Range("D2").Value & "\"
   For iSheet = Worksheets.Count - 13 To Worksheets.Count
      Worksheets(iSheet).Copy
      ActiveWorkbook.SaveAs sPath & ActiveSheet.Name
      ActiveWorkbook.Close savechanges:=False
   Next iSheet
   Application.ScreenUpdating = True
   MsgBox "Job is complete"
End Sub

I am a beginner when it comes to VBA so I am glad of any help!!

Thanks,
Alan

 

[AlphaFrog]

Sub Save_Project_Reports()
    
    Dim ws As Worksheet
    
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Range("A3").Text = "Project Reports" Then
            ws.Copy 'Copy the sheet to its' own workbook
            ActiveWorkbook.SaveAs Range("D2").Value & "\" & ActiveSheet.Name & ".xls"
            ActiveWorkbook.Close SaveChanges:=False
        End If
    Next ws
    Application.ScreenUpdating = True
    
    MsgBox "Job is complete"
    
End Sub

 

[sweeneytime]

Thanks a million for that, its spot on now.

 

[AlphaFrog]

You're welcome.