免费赠送【工具软件】Excel文件拆分

xiamen168

【概要】以表单为单位进行文件拆分。由多个表单组成的文件将按照表单为单位进行拆分，并保存。原文件原封不动保留下来。http://t.cn/RPOiJKK

1. Private Sub CommandButton1_Click()
   
2.     On Error GoTo Err1
   
3.     '打开文件对话框
   
4.     selectfile = Application _
   
5.     .GetOpenFilename("Excel工作簿 (*.xls*), *.xls*", , "请指定要拆分的文件。")
   
6.     '.GetOpenFilename("Excel工作簿 (*.xls), *.xls", , "请指定要拆分的文件。")
   
7.     '保存最初路径
   
8.     biginpath = CurDir()
   
9.    
   
10.     '打开所选定的文件
    
11.     If selectfile <> False Then
    
12.         Workbooks.Open Filename:=selectfile
    
13.     Else
    
14.         Exit Sub
    
15.     End If
    
16.    
    
17.     '删除表单
    
18.     Dim ws As Worksheet
    
19.     Application.DisplayAlerts = False    '---隐藏警告消息
    
20.     For Each ws In ActiveWorkbook.Worksheets
    
21.         If Application.WorksheetFunction.CountA(ws.UsedRange) = 0 Then
    
22.             ws.Delete   '---删除未使用的表单
    
23.         End If
    
24.     Next ws
    
25.    
    
26.     Application.DisplayAlerts = True     '---警告消息显示
    
27.     '指定另存为
    
28.     '打开文件对话框
    
29.     selectfolder = Application _
    
30.     .GetSaveAsFilename("选择场所", , , "指定另存为")
    
31.     myfolder = CurDir()
    
32.    
    
33.     If selectfolder <> False Then
    
34.         Application.ScreenUpdating = False        '关闭界面切换
    
35.         '获取表名
    
36.         For Each n In Sheets
    
37.             newfilename = n.Name '获取表名
    
38.             n.Copy              '把表单复制到新文件中
    
39.             pathname = myfolder & "" & newfilename  '取得绝对路径
    
40.             ActiveSheet.PageSetup.PrintArea = ""     '清除打印范围
    
41.             ActiveWorkbook.Close savechanges:=True, Filename:=pathname, routeworkbook:=False
    
42.         Next n
    
43.         ChDir biginpath
    
44.         MsgBox "成功！"
    
45.     End If
    
46.    
    
47.     '原文件结束
    
48.     ActiveWorkbook.Close savechanges:=False
    
49.     Application.ScreenUpdating = True        '解除界面控制
    
50.     Exit Sub
    
51.    
    
52. Err1:
    
53.     MsgBox "出错了。"
    
54. End Sub
    

复制代码

该贴已经同步到 xiamen168的微博

xiamen168

跟我学VBA！

laneryumaomi

不错呀，感谢分享

ylf969

不错呀，感谢分享