excel将一个工作表针对条件拆分成多个工作表图文教程-英雄云拓展知识分享

1. Sub CFGZB()   
2.   
3.     Dim myRange As Variant   
4.   
5.     Dim myArray   
6.   
7.     Dim titleRange As Range   
8.   
9.     Dim title As String   
10.   
11.     Dim columnNum As Integer   
12.   
13.     myRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)   
14.   
15.     myArray = WorksheetFunction.Transpose(myRange)   
16.   
17.     Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", Type:=8)   
18.   
19.     title = titleRange.Value   
20.   
21.     columnNum = titleRange.Column   
22.   
23.     Application.ScreenUpdating = False   
24.   
25.     Application.DisplayAlerts = False   
26.   
27.     Dim i&, Myr&, Arr, num&   
28.   
29.     Dim d, k   
30.   
31.     For i = Sheets.Count To 1 Step ⑴   
32.   
33.         If Sheets(i).Name <> "数据源" Then   
34.   
35.             Sheets(i).Delete   
36.   
37.         End If   
38.   
39.     Next i   
40.   
41.     Set d = CreateObject("Scripting.Dictionary")   
42.   
43.     Myr = Worksheets("数据源").UsedRange.Rows.Count   
44.   
45.     Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))   
46.   
47.     For i = 1 To UBound(Arr)   
48.   
49.         d(Arr(i, 1)) = ""  
50.   
51.     Next   
52.   
53.     k = d.keys   
54.   
55.     For i = 0 To UBound(k)   
56.   
57.         Set conn = CreateObject("adodb.connection")   
58.   
59.         conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName   
60.   
61.         Sql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"  
62.   
63.         Worksheets.Add after:=Sheets(Sheets.Count)   
64.   
65.         With ActiveSheet   
66.   
67.             .Name = k(i)   
68.   
69.             For num = 1 To UBound(myArray)   
70.   
71.                 .Cells(1, num) = myArray(num, 1)   
72.   
73.             Next num   
74.   
75.             .Range("A2").CopyFromRecordset conn.Execute(Sql)   
76.   
77.         End With   
78.   
79.         Sheets(1).Select   
80.   
81.         Sheets(1).Cells.Select   
82.   
83.         Selection.Copy   
84.   
85.         Worksheets(Sheets.Count).Activate   
86.   
87.         ActiveSheet.Cells.Select   
88.   
89.         Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _   
90.   
91.                                SkipBlanks:=False, Transpose:=False   
92.   
93.         Application.CutCopyMode = False   
94.   
95.     Next i   
96.   
97.     conn.Close   
98.   
99.     Set conn = Nothing   
100.   
101.     Application.DisplayAlerts = TRUE   
102.   
103.     Application.ScreenUpdating = True   
104.   
105. End Sub   
106.   

5、以下图所示，插入一个控件按钮，并指定宏到刚才插入的模块代码。

6、点击插入的按钮控件，针对提示选择标题行和要拆分的列字段，本例选择“姓名”字段拆分，固然也能够选择C列的“名称”进行拆分，看实际需求。

7、代码运行终了后在工作簿后面会出现很多工作表，每一个工作表都是单唯一个人的数据。具体以下图所示：

8、注意：

1）原始数据表要从第一行开始有数据，并且不能有合并单元格；

2）打开工作簿时需要开启宏，否则将没法运行代码。

以上就是excel将一个工作表针对条件拆分成多个工作表图文教程，希望能对大家有所帮助！