表另存簿

xing_chen

老师！有簿，含有多表，我希望将表另存为独立的工作簿并重命名。簿中编有代码，但修改测试均未如愿，只能生成1簿且簿名也未能修改为我所需要的设想。敬请老师修改。谢谢

liulang0808

Sub 表另存簿()
    Dim sh As Worksheet, path$, ss$
    With Application.FileDialog(msoFileDialogFolderPicker)
         If .Show Then
             strPath = .SelectedItems(1)
         Else
         Exit Sub
     End If
    End With
    Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets(Array("1", "2", "3")):
        sh.Copy
        ss = InputBox("请输入新表名称：", "提示", "表")
        ActiveSheet.Name = ss
        ActiveWorkbook.SaveAs Filename:=path & sh(ss).Name & ".xls"
        ActiveWorkbook.Close
    Next
    Application.ScreenUpdating = True
End Sub

liulang0808

不知道楼主具体设想，增加了一行代码，供参考

ykcbf1100

你最明显的错误在于path应该是strpath。

其它还有错，我改了下。

getset

将'ActiveWorkbook.SaveAs Filename:=path & sh(ss).Name & ".xls" 改成 ActiveWorkbook.SaveAs Filename:=strpath & "\" & ss & ".xls"

cyq4896

参与一下。

xing_chen

cyq4896 发表于 2023-5-27 21:13
参与一下。

谢谢老师！运行如愿

xing_chen

getset 发表于 2023-5-27 20:50
将'ActiveWorkbook.SaveAs Filename:=path & sh(ss).Name & ".xls" 改成 ActiveWorkbook.SaveAs Filename:= ...

谢谢老师！按你意思修改，运行如愿

xing_chen

ykcbf1100 发表于 2023-5-27 20:14
你最明显的错误在于path应该是strpath。

其它还有错，我改了下。

谢谢老师！ wb.SaveAs strPath & "\" & ss, 56，此句现黄，以改。运行如愿

xing_chen

liulang0808 发表于 2023-5-27 19:59
不知道楼主具体设想，增加了一行代码，供参考

谢谢老师！ActiveWorkbook.SaveAs Filename:=path & sh(ss).Name & ".xls"，此句现黄，修改后运行如愿。