VBA - Save each sheet as new workbook with sheet name

[Prish]

Can anyone help me with the following code i wrote:

It only saves the first sheet.

Sub copysheet()

Dim ws As Worksheet


For Each ws In ThisWorkbook.Worksheets


ActiveSheet.Copy


wb_name = ActiveSheet.Name


Application.DisplayAlerts = False


ActiveWorkbook.SaveAs Filename:= _
"C:\Users\Username\Desktop\" & wb_name & " Budget " & Format(Date, "dd-mm-yy") & ".xlsx", FileFormat:=51


ActiveWorkbook.Close


Application.DisplayAlerts = True


Next ws


End Sub

Edit: I figured it out - change activesheet.copy to ws.copy

 

[DanteAmor]

It is correct, change activesheet by ws

Sub copysheet()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In ThisWorkbook.Worksheets
        ws.Copy
        wb_name = ws.Name
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Users\Username\Desktop\" & wb_name & " Budget " & Format(Date, "dd-mm-yy") & ".xlsx", FileFormat:=51
        ActiveWorkbook.Close
    Next ws
    Application.DisplayAlerts = True
End Sub

 

[ceasar47]

It is correct, change activesheet by ws

Sub copysheet()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In ThisWorkbook.Worksheets
        ws.Copy
        wb_name = ws.Name
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Users\Username\Desktop\" & wb_name & " Budget " & Format(Date, "dd-mm-yy") & ".xlsx", FileFormat:=51
        ActiveWorkbook.Close
    Next ws
    Application.DisplayAlerts = True
End Sub

Hi DanteAmor,

Thanks for this VBA.

I wanted to add a folder picker in this code which can pick a .xlsx file and show a "Complete" popup after operation completes. Also I would like to add input from the user about specifying the folder where the operated files will be saved.


Please guide what to correct in the following code:

Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim i As Integer, j As Integer, f As Integer, s1 As String, s2 As String, ro As Integer, col As Integer, row As Integer, s As Integer, r As Integer
Dim m As Integer, mm As Integer
'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With
    
'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xlsx*"

Sub copysheet()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In ThisWorkbook.Worksheets
        ws.Copy
        wb_name = ws.Name
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Users\Lenovo Laptop\Desktop\" & wb_name & ".xlsx", FileFormat:=51
        ActiveWorkbook.Close
    Next ws
    Application.DisplayAlerts = True
End Sub
'Message Box when tasks are completed
  MsgBox "Task Complete!"

Thanks !