“您好，非常感谢您对我的帮助，解决了我的大忙，能帮我进一步完善一下吗？

Sub 另存所有工作表为工作簿()
Dim sht As Worksheet
Application.ScreenUpdating = False '禁用屏幕刷新
Application.DisplayAlerts = False
ipath = ThisWorkbook.Path & "\" '默认保存在当前文件夹
For Each sht In Sheets
If sht.Name <> "目录" Then
If sht.Range("D4") <> "" Then
myipath = ipath & sht.Range("D4")
Else
myipath = ipath & "新建文件夹"
End If
If Dir(myipath, vbDirectory) = "" Then MkDir myipath
sht.Copy
ActiveWorkbook.SaveAs myipath & "\" & sht.Name & ".xls"
ActiveWorkbook.Close
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True '恢复屏幕刷新
End Sub