SAVE SHEETS AS WORKBOOK

[gleamng]

GOOD DAY ALL, I HAVE THIS VBA TO SAVE WORKSHEETS AS WORKBOOKS AND IT WORKS FINE BUT THE PROBLEM I HAVE IS THAT THE MACRO NEEDED TO BE RUN ON ALL OPENED FILE AND AN UNSAVED FILE. SO I WANT VBA TO SAVE TO A FOLDER NAMED VER ON DESKTOP AND I WANT IT TO SAVE THE FILES IN A FOLDER WITH TODAY'S DATE INSIDE VER ON THE DESKTOP.

THANK YOU FOR YOUR HELP, BELOW IS THE CODE

Sub VerSheetsToWorkbooks()
      Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
      MyFilePath$ = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
            With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
            '      End With
            On Error Resume Next    '<< a folder exists
            MkDir MyFilePath            '<< create a folder
            For N = 1 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