导出sheet到新文件夹当中

Sub 导出当前客户达成分析()
Application.ScreenUpdating = False
myName1 = Sheets("日期统计表").Range("B1") '客户名称
myName = Sheets("配送明细报表").Range("BA2")
mypath = ThisWorkbook.Path
If Len(Dir(mypath & myName, vbDirectory)) < 1 Then
MkDir mypath & "\" & myName
End If
Sheets("日期统计表").Select
Sheets("日期统计表").Copy
ActiveSheet.Unprotect Password:=123
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Shapes.Range(Array("Button 1")).Select
Selection.Delete
Range("B1:C1").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
ActiveWorkbook.SaveAs Filename:=mypath & "\" & myName & "\" & myName1 & ".xlsm", FileFormat _
:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWindow.Close
Application.ScreenUpdating = True
End Sub