Try this;

Sub CreateWorkbooksFromSheets()
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim filePath As String
    ' Loop through each worksheet in the active workbook
    For Each ws In ThisWorkbook.Worksheets
        ' Create a new workbook
        Set newWb = Workbooks.Add
        ' Copy the current worksheet to the new workbook
        ws.Copy Before:=newWb.Sheets(1)
        ' Delete the default empty sheets in the new workbook (if any exist)
        Application.DisplayAlerts = False 
        ' Suppress prompts
        Dim i As Long
        For i = newWb.Sheets.Count To 2 Step -1 
            ' start at the end and work backwards
            newWb.Sheets(i).Delete
        Next i
        Application.DisplayAlerts = True 
        ' Restore prompts
        ' Construct a file path and name (you can customize this)
        filePath = ThisWorkbook.Path & "\" & ws.Name & ".xlsx"
        ' Save the new workbook    newWb.SaveAs Filename:=filePath, FileFormat:=xlOpenXMLWorkbook
        ' Close the new workbook
        newWb.Close
    Next ws
    MsgBox "Workbooks created for each worksheet.", vbInformation
End Sub