亦有资源网

Sub 当前工作表到工作簿()

On Error GoTo line

ActiveSheet.Copy

ActiveWorkbook.Close savechanges:=True, Filename:="E:\2020年下期\a.xlsx"

Exit Sub

line:

ActiveWorkbook.Close False

End Sub

Sub 将所有工作表另存为工作簿()

Dim sht As Worksheet

Application.ScreenUpdating = False

For Each sht In Sheets

If sht.Name = "Sheet1" Then GoTo line

sht.Copy

ActiveWorkbook.SaveAs Filename:="E:\2020年下期\" & sht.Name & ".xlsx"

ActiveWorkbook.Close

line:

Next

Application.ScreenUpdating = True

End Sub

Sub 所有工作表保存为工作簿()

Application.ScreenUpdating = False '屏幕不更新

Dim i As Integer

Dim j As Integer

Dim str As String

j = Worksheets.Count - 1 '减去最后一个空表

For i = j To 1 Step -1

Worksheets(i).Copy

str = ActiveWorkbook.Sheets(1).Name '将工作簿 名称改为工作表名称

ActiveWorkbook.SaveAs Filename:="E:\2020年下期\" & str & ".xlsx"

ActiveWorkbook.Close savechanges:=True

Next

Application.ScreenUpdating = True

End Sub

Sub 部分工作表保存为工作簿()

Application.ScreenUpdating = False '屏幕不更新

Dim str As String

Worksheets(1).Copy

str = ActiveWorkbook.Sheets(1).Name '将工作簿 名称改为工作表名称

ActiveWorkbook.SaveAs Filename:="E:\2020年下期\" & str & ".xlsx"

ActiveWorkbook.Close savechanges:=True

Worksheets(2).Copy

str = ActiveWorkbook.Sheets(1).Name '将工作簿 名称改为工作表名称

ActiveWorkbook.SaveAs Filename:="E:\2020年下期\" & str & ".xlsx"

ActiveWorkbook.Close savechanges:=True

Application.ScreenUpdating = True

End Sub

Sub 指定工作表保存为工作簿()

Application.ScreenUpdating = False '屏幕不更新

Dim str As String

Worksheets("a").Copy

str = ActiveWorkbook.Sheets(1).Name '将工作簿 名称改为工作表名称

ActiveWorkbook.SaveAs Filename:="E:\2020年下期\" & str & ".xlsx"

ActiveWorkbook.Close savechanges:=True

Worksheets("b").Copy

str = ActiveWorkbook.Sheets(1).Name '将工作簿 名称改为工作表名称

ActiveWorkbook.SaveAs Filename:="E:\2020年下期\" & str & ".xlsx"

ActiveWorkbook.Close savechanges:=True

Application.ScreenUpdating = True

End Sub