作者:乔山办公网日期:
返回目录:excel表格制作
用以下宏代码解决:
Sub 拆分为独立工作薄e69da5e6ba90e79fa5e98193332()
Application.ScreenUpdating = False
Dim wb As Excel.Workbook
Dim sh As Excel.Worksheet
t = Timer
Set fso = CreateObject("scripting.filesystemobject")
f = Dir(ThisWorkbook.Path & "\*.xls*") '生成查找EXCEL的目录,可以适应不同版本
Do While f <> "" '在目录中循环
If f <> ThisWorkbook.Name Then '如果不是打开的工作簿
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f) '依次打开目录工作薄
If fso.folderexists(ThisWorkbook.Path & "\" & Split(wb.Name, ".")(0)) Then fso.deletefolder ThisWorkbook.Path & "\" & Split(wb.Name, ".")(0)
MkDir ThisWorkbook.Path & "\" & Split(wb.Name, ".")(0)
For Each sh In wb.Worksheets '在打开的工作薄的工作表中循环
sh.Copy '拷贝工作表为工作薄
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Split(wb.Name, ".")(0) & "\" & sh.Name & ".xlsx" '工作表保存为工作薄
ActiveWorkbook.Close '关闭新建立的工作薄
Next
wb.Close False '关闭打开的工作薄
End If
f = Dir
Loop '结束循环
MsgBox "ok!耗时" & Format(Timer - t, "00") & "秒"
Application.ScreenUpdating = True
End Sub