EXCEL将各个Sheet工作表另存为新工作簿

发布于：2021-12-20 09:08:05  栏目：技术文档

　　通过EXCEL中的VBA就可以轻松解决。

　　Sub SaveAs()

　　On Error Resume Next

　　Dim FolderPath As String, FolderName As String, BN As String

　　Dim ReturnValue As Integer

　　BN=ActiveWorkbook.Name

　　FolderPath=ThisWorkbook.Path

　　FolderName=Mid(BN, 1, InStrRev(BN, ".", Len(BN)) - 1)

　　Dim MyFile As Object

　　Set MyFile=CreateObject("Scripting.FileSystemObject")

　　If MyFile.folderexists(FolderPath & "" & FolderName & "-Saved") Then

　　ReturnValue=MsgBox("文件夹已存在，是否更新内容？", vbOKCancel, "Caution!")

　　If ReturnValue=2 Then Exit Sub

　　Else

　　MyFile.CreateFolder (FolderPath & "" & FolderName & "-Saved")

　　Set MyFile=Nothing

　　End If

　　Application.ScreenUpdating=False

　　Application.DisplayAlerts=False

　　Dim i As Integer

　　For i=1 To Sheets.Count

　　Set Wk=Workbooks.Add

　　Workbooks(BN).Sheets(i).Copy before:=Wksheets("Sheet1")

　　Wk.SaveAs FolderPath & "" & FolderName & "-Saved" & ThisWorkbook.Sheets(i).Name

　　Wk.Close

　　Next i

　　Application.DisplayAlerts=True

　　Application.ScreenUpdating=True

　　End Sub

相关推荐