Sub 保存当前工作表()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Dim ShtName As String, ShtPath As String, ResMsg As VbMsgBoxResult
If ActiveSheet.Range("a1").Value = "" Then MsgBox "当前工作表A1单元格为空白!" & Chr(10) & "请在A1单元格输入内容!", vbOKOnly + 16, "提示":exit sub
ShtName = ActiveSheet.Range("a1").Value
ShtPath = CStr(Application.InputBox("请输入工作表保存的路径", "确认路径", "F:/files", , , , , 2))
ResMsg = MsgBox("是否清楚表格中的内容" & Chr(10) & "选择是将保存表格" & Chr(10) & "选择否不保存表格", vbYesNo + 32, "提示")
Select Case ResMsg
Case vbYes
ActiveSheet.Copy
ActiveWorkbook.SaveAs ShtPath & "\" & ShtName
ActiveWorkbook.Close True
MsgBox "工作表已保存到" & ShtPath & "\" & ShtName, vbOKOnly, "提示"
Case vbNo
Exit Sub
End Select
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub