Sub Extract_Current_Sheet_to_File()

Dim strName As String

Dim strPath As String



On Error Resume Next



strPath = ActiveWorkbook.Path ' <<<

strName = ActiveSheet.Range("A1").Value

Sheets(strName).Copy ' copy  this sheet  to a new workbook, must use no
parameters

ActiveWorkbook.SaveAs Filename:=strPath & "\" & strName

ActiveWorkbook.Close

End Sub