点点鼠标，将Excel按列拆成工作表或工作薄(美化版)

shenjianrong163

功能：通过窗口打开Excel文件，选择其中任意一个工作表，随意指定列后，系统将Excel文件拆分成工作表或拆分成独立的工作薄。
步骤：
    1.单击“拆成工作表”后，系统弹出窗口要求用户选择要拆分的Excel文件，之后再次分别要求选择列和列标题所在的行。
    2.单击“拆成工作薄”后先选择拆分文件存放位置，再打开要拆分的Excel文件，之后再次分别要求选择列和列标题所在的行。
    3.等待操作完成。

1

1. Option Explicit
   
2. Public StartNum As Integer '全局变量用来记录要拆分的工作薄的工作表数
   
3. 
   
4. Sub 按列拆分成工作簿()
   
5.     Dim i&, j&, k&, Rg As Range, RowNum&, ColNum&, dic, arr, brr(), St, StFile$, aa, cc, wb As Workbook, tt
   
6.     Dim sh, FileName, objShp As Object
   
7.     Set dic = CreateObject("scripting.dictionary")
   
8.     St = Application.FileDialog(msoFileDialogFolderPicker).Show '如果选择了文件夹就返回-1,不选择文件夹就返回0
   
9.     If St <> 0 Then
   
10.         StFile = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)  '取选择的保存文件的文件夹路径
    
11.     Else
    
12.         Exit Sub  '没有选择保存路径，退出程序
    
13.     End If
    
14.     FileName = Application.GetOpenFilename("Excel 文件 (*.xls*),*.xls*", , "请选择要拆分的excel文件!", , 0)
    
15.     If FileName = False Then Exit Sub   '如果没有选择文件，退出程序
    
16.     Set sh = Workbooks.Open(FileName) '打开要拆分的Excel文件
    
17.     FileName = ThisWorkbook.Name
    
18.     '下面通过InputBox这个方法确定你要拆分的列
    
19.     On Error GoTo 100 '如果有错误跳转到100处
    
20.     Set Rg = Application.InputBox("请选择您要拆分的列（可以单击其中一个单元格）", "选择", Type:=8) '用了这句不可以关闭屏幕刷新
    
21.     ColNum = Rg.Column '把要拆分的列赋值变量 ColNum
    
22.     Sheets(Rg.Parent.Name).Activate '将选择的工作表设置为活动工作表
    
23.     '下面通过InputBox这个方法确定数据（表头、列标题除外）开始所在的行
    
24.     On Error GoTo 100 '如果有错误跳转到100处
    
25.     Set Rg = Application.InputBox("请选择标题所在的行（可以单击其中一个单元格）", "选择", Type:=8) '用了这句不可以关闭屏幕刷新
    
26.     RowNum = Rg.Row '把数据开始的行赋值变量 RowNum
    
27.     On Error GoTo 0 '下面的代码有错误,继续报错
    
28.     tt = Timer  '记时开始
    
29.     If Cells(RowNum, ColNum).MergeCells Then  '判断所选标题行是否是合并单元格
    
30.         RowNum = Split(Cells(RowNum, ColNum).MergeArea.Address, "$")(UBound(Split(Cells(RowNum, ColNum).MergeArea.Address, "$"))) '合并单元格的最大行号
    
31.         cc = Split(Cells(RowNum - Cells(RowNum, ColNum).MergeArea.Rows.Count + 1, Cells(RowNum - Cells(RowNum, ColNum).MergeArea.Rows.Count + 1, Columns.Count).End(xlToLeft).Column).Address, "$")(1) '将合并单元格列标题最后一行非空数据的列号转为字母
    
32.     Else
    
33.         cc = Split(Cells(RowNum, Cells(RowNum, Columns.Count).End(xlToLeft).Column).Address, "$")(1) '将列标题最后一行非空数据的列号转为字母
    
34.     End If
    
35.     arr = Sheets(Rg.Parent.Name).Range("A1:" & cc & Cells(Rows.Count, ColNum).End(xlUp).Row)
    
36.     For j = RowNum + 1 To UBound(arr)
    
37.         If arr(j, ColNum) <> "" Then dic(arr(j, ColNum)) = ""   '字典去重拆分的列数据
    
38.     Next
    
39.     If dic.Count = 0 Then MsgBox "您选择拆分的列没有数据，即将退出程序!", 64, "温馨提示": Exit Sub '防止用户选择的列没有数据
    
40.     Application.ScreenUpdating = False   '关闭屏幕更新
    
41.     Application.DisplayAlerts = False    '关闭询问对话框
    
42.     For Each aa In dic.Keys
    
43.         Sheets(1).Copy ''复制方式保留原格式
    
44.         Set wb = ActiveWorkbook '把分表折成的独立的工作簿设置为活动工作簿
    
45.         With wb
    
46.             If .Sheets(1).Name <> "Sheet1" Then .Sheets(1).Name = "Sheet1"
    
47.             .SaveAs FileName:=StFile & "" & aa & ".xlsx", FileFormat:=xlWorkbookDefault  '把新的工作簿保存为当前的目录下
    
48.             .Sheets(1).Range("A" & RowNum + 1 & ":" & cc & Cells(Rows.Count, 1).End(xlUp).Row + 2).Borders.LineStyle = xlNone '清除标题后面的边框
    
49.             .Sheets(1).Range("A" & RowNum + 1 & ":" & cc & Cells(Rows.Count, 1).End(xlUp).Row + 2).ClearContents    '清除标题后面的内容
    
50.             For Each objShp In ActiveSheet.Shapes
    
51.                 objShp.Delete   '删除表中多余的Shape，如果要保留可以将此循环语句注释掉
    
52.             Next
    
53.             ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
54.             k = 0
    
55.             For i = RowNum + 1 To UBound(arr)   '从数据行开始循环判断，列数据相同的存入数组brr
    
56.                 If arr(i, ColNum) = aa Then
    
57.                     k = k + 1
    
58.                     For j = 1 To UBound(arr, 2)
    
59.                         brr(k, j) = arr(i, j)
    
60.                     Next
    
61.                 End If
    
62.             Next
    
63.             .Sheets(1).Range("A" & RowNum + 1).Resize(k, UBound(brr, 2)) = brr  '数组内容存入第一个工作表
    
64.             .Sheets(1).Range("A" & RowNum + 1 & ":" & Split(Cells(1, UBound(brr, 2)).Address, "$")(1) & k + RowNum).Borders.LineStyle = xlContinuous '设置标题后面的边框
    
65.             .Sheets(1).Rows(RowNum + 1 + k & ":" & RowNum + 1 + UBound(arr)).Clear '清除后面多余的行的格式
    
66.             .Close True '关闭并保存工作簿
    
67.         End With
    
68.     Next
    
69.     Application.DisplayAlerts = True    '打开询问对话框
    
70.     Application.ScreenUpdating = True   '打开屏幕更新
    
71.     MsgBox "亲,拆分完毕,请查阅!用时:" & Format(Timer - tt, "0.0000") & "秒!", 64, "温馨提示"
    
72.     Shell "explorer.exe " & StFile, 1 '显示拆分后的文件夹
    
73.     Exit Sub
    
74. 100:
    
75.     MsgBox "您选择了取消或者是关闭，即将退出程序", 64, "温馨提示"
    
76. End Sub
    
77. 
    
78. Sub 按列拆分成工作表()
    
79.     Dim i&, j&, k&, Rg As Range, RowNum&, ColNum&, dic, arr, brr(), aa, cc, tt, sht
    
80.     Dim sh, FileName, objShp As Object
    
81.     Set dic = CreateObject("scripting.dictionary")
    
82.     FileName = Application.GetOpenFilename("Excel 文件 (*.xls*),*.xls*", , "请选择要拆分的excel文件!", , 0)
    
83.     If FileName = False Then Exit Sub   '如果没有选择文件，退出程序
    
84.     Set sh = Workbooks.Open(FileName)  '打开要拆分的Excel文件
    
85.     If StartNum = 0 Then StartNum = Sheets.Count '记录开始时的工作表数
    
86.     If StartNum < Sheets.Count Then Call DelSheets '拆分过工作表，调用DelSheets()将多余的删除
    
87.     '下面通过InputBox这个方法确定你要拆分的列
    
88.     On Error GoTo 100 '如果有错误跳转到100外
    
89.     Set Rg = Application.InputBox("请选择您要拆分的列（可以单击其中一个单元格）", "选择", Type:=8) '用了这句不可以关闭屏幕刷新
    
90.     ColNum = Rg.Column '把要拆分的列赋值变量 ColNum
    
91.     Sheets(Rg.Parent.Name).Activate '将选择的工作表设置为活动工作表
    
92.     '下面通过InputBox这个方法确定数据（表头、列标题除外）开始所在的行
    
93.     On Error GoTo 100 '如果有错误跳转到100外
    
94.     Set Rg = Application.InputBox("请选择标题所在的行（可以单击其中一个单元格）", "选择", Type:=8) '用了这句不可以关闭屏幕刷新
    
95.     RowNum = Rg.Row '把数据开始的行赋值变量 RowNum
    
96.     On Error GoTo 0 '下面的代码有错误,继续报错
    
97.     tt = Timer  '记时开始
    
98.     If Cells(RowNum, ColNum).MergeCells Then  '判断所选标题行是否是合并单元格
    
99.         RowNum = Split(Cells(RowNum, ColNum).MergeArea.Address, "$")(UBound(Split(Cells(RowNum, ColNum).MergeArea.Address, "$"))) '合并单元格的最大行号
    
100.         cc = Split(Cells(RowNum - Cells(RowNum, ColNum).MergeArea.Rows.Count + 1, Cells(RowNum - Cells(RowNum, ColNum).MergeArea.Rows.Count + 1, Columns.Count).End(xlToLeft).Column).Address, "$")(1) '将合并单元格列标题最后一行非空数据的列号转为字母
     
101.     Else
     
102.         cc = Split(Cells(RowNum, Cells(RowNum, Columns.Count).End(xlToLeft).Column).Address, "$")(1) '将列标题最后一行非空数据的列号转为字母
     
103.     End If
     
104.     arr = Sheets(Rg.Parent.Name).Range("A1:" & cc & Cells(Rows.Count, ColNum).End(xlUp).Row)
     
105.     For j = RowNum + 1 To UBound(arr)
     
106.         If arr(j, ColNum) <> "" Then dic(arr(j, ColNum)) = ""   '字典去重拆分的列数据
     
107.     Next
     
108.     If dic.Count = 0 Then MsgBox "您选择拆分的列没有数据，即将退出程序!", 64, "温馨提示": Exit Sub '防止用户选择的列没有数据
     
109.     Application.ScreenUpdating = False  '关闭屏幕更新
     
110.     Application.DisplayAlerts = False   '关闭询问对话框
     
111.     For Each sht In Sheets
     
112.         If InStr(Join(dic.Keys, ","), sht.Name) > 0 Then sht.Delete '循环判断存在dic.Keys中的工作表则删除
     
113.     Next
     
114.     For Each aa In dic.Keys
     
115.         Sheets(1).Copy After:=Sheets(Sheets.Count) '复制方式保留原格式
     
116.         Sheets(Sheets.Count).Name = aa  '重命名工作表
     
117.         Sheets(Sheets.Count).Activate   '设置为活动工作表
     
118.         Sheets(Sheets.Count).Range("A" & RowNum + 1 & ":" & cc & Cells(Rows.Count, 1).End(xlUp).Row + 2).Borders.LineStyle = xlNone '清除标题后面的边框
     
119.         Sheets(Sheets.Count).Range("A" & RowNum + 1 & ":" & cc & Cells(Rows.Count, 1).End(xlUp).Row + 2).ClearContents    '清除标题后面的内容
     
120.         For Each objShp In ActiveSheet.Shapes
     
121.             objShp.Delete   '删除表中多余的Shape，如果要保留可以将此循环语句注释掉
     
122.         Next
     
123.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
     
124.         k = 0
     
125.         For i = RowNum + 1 To UBound(arr)   '从数据行开始循环判断，列数据相同的存入数组brr
     
126.             If arr(i, ColNum) = aa Then
     
127.                 k = k + 1
     
128.                 For j = 1 To UBound(arr, 2)
     
129.                     brr(k, j) = arr(i, j)
     
130.                 Next
     
131.             End If
     
132.         Next
     
133.         Sheets(Sheets.Count).Range("A" & RowNum + 1).Resize(k, UBound(brr, 2)) = brr  '数组内容存入第一个工作表
     
134.         Sheets(Sheets.Count).Range("A" & RowNum + 1 & ":" & Split(Cells(1, UBound(brr, 2)).Address, "$")(1) & k + RowNum).Borders.LineStyle = xlContinuous '设置标题后面的边框
     
135.         Sheets(Sheets.Count).Rows(RowNum + 1 + k & ":" & RowNum + 1 + UBound(arr)).Clear '清除后面多余的行的格式
     
136.     Next
     
137.     Sheets(Rg.Parent.Name).Activate
     
138.     Application.DisplayAlerts = True '打开询问对话框
     
139.     Application.ScreenUpdating = True   '打开屏幕更新
     
140.     MsgBox "工作表拆分完成!用时:" & Format(Timer - tt, "0.0000") & "秒!", 64, "温馨提示"
     
141.     Exit Sub
     
142. 100:
     
143.     MsgBox "您选择了取消或者是关闭，即将退出程序", 64, "温馨提示"
     
144. End Sub

复制代码

请参考附件： 点点鼠标，将Excel按列拆成工作表或工作薄(美化版).rar (221.91 KB, 下载次数: 506)

2020-5-22 07:54 上传

点击文件名下载附件

shenjianrong163

本拆分工具的特点：
    1.点点鼠标，几步操作；
    2.拆分后保留原格式；
    3.用户只需运行本工具即可，用此工具去拆分相应的Excel文件；
    4.可以对Excel文件中的任何一个工作表来拆分；
    5.拆成工作薄和工作表两种选择。

rrxfw

很强大的工具

wds1061

这个太强大了，感谢无私分享！

yaitlt

太好了，谢谢楼主分享。

yes363001640

注释很清楚，方便学习的好源码。

1693167542

谢谢，感谢分享

1693167542

感谢分享，

danielwaiting

如果是一簿多表按指定列拆分成多簿多表呢

电鳗01

精美，实用，谢谢分享