灵活拆分工具

interxujun

牛掰，牛掰，谢谢

素心剑

太好了，谢谢楼主分享。有时需要汇总求和，有办法吗？

cjc209

lsc900707 发表于 2016-12-13 17:56
感谢朱老师分享这么好的工具。先帮顶。

太死板了 如果是多列条件怎么办？？？

cjc209

随便发一个都比版主的好

cjc209

随意多条件工作表拆分工具

1. Sub 工作表拆分()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim arr As Variant
   
5.     Dim i, s As Integer
   
6.     Dim brr()
   
7.     Dim wb, wb1 As Workbook
   
8.     Dim d As Object
   
9.     Dim hlrow As Integer, cutcolumn As Integer, cuttype As Integer
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     Dim sh As Worksheet
    
12.     hlrow = InputBox("请输入标题最末行数：", "拆分表格", "1")
    
13.     bwhs = InputBox("请输入表尾的总行数：", "拆分表格", "0")
    
14.     cutcolumn = InputBox("请输入拆分依据列（第一列是1，第二列是2，以此类推）：", "拆分表格", "1")
    
15.     cuttype = InputBox("请选择拆分类型（拆分到本工作簿是1，拆分为多个独立工作簿是2，拆分为一个工作簿是3）：", "拆分表格", "1")
    
16.     bb = MsgBox("是否去除表尾 是为去除 否为保留表尾", vbYesNo)
    
17. 
    
18.     lastCol = Selection.SpecialCells(xlCellTypeLastCell).Column
    
19.     lastRow = Selection.SpecialCells(xlCellTypeLastCell).Row
    
20.     arr = ActiveSheet.Range("a1", ActiveSheet.Cells(lastRow - bwhs, lastCol))
    
21.     For i = hlrow + 1 To UBound(arr)
    
22.         If Not d.exists(arr(i, cutcolumn)) Then
    
23.           If Cells(i, cutcolumn) = "" Then GoTo 3
    
24.             Set d(arr(i, cutcolumn)) = ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2))
    
25.         Else
    
26.             Set d(arr(i, cutcolumn)) = Union(d(arr(i, cutcolumn)), ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2)))
    
27. 
    
28.         End If
    
29. 3:
    
30.     Next i
    
31.    x = d.keys
    
32. If cuttype = 1 Then
    
33. 
    
34. For k = 0 To d.Count - 1
    
35.          
    
36.          
    
37.             Worksheets.Add after:=Worksheets(Worksheets.Count)
    
38.          
    
39.             ActiveSheet.Name = x(k)
    
40.             ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy ActiveSheet.[a1]
    
41.             d.items()(k).Copy ActiveSheet.Cells(hlrow + 1, 1)
    
42.             If bb = 7 Then
    
43.             zdRow = Selection.SpecialCells(xlCellTypeLastCell).Row
    
44.             qsh = lastRow - Val(bwhs) + 1
    
45.             ThisWorkbook.Worksheets(1).Rows(qsh & ":" & lastRow + 1).Copy ActiveSheet.Cells(zdRow + 1, 1)
    
46.             Else
    
47.            End If
    
48. Next k
    
49. End If
    
50.   If cuttype = 3 Then
    
51.         Application.SheetsInNewWorkbook = d.Count
    
52.         Set wb1 = Workbooks.Add
    
53.         i = 1
    
54.         For Each k In d.keys
    
55.             wb1.Worksheets(i).Name = k
    
56.            wb1.Worksheets(i).Activate
    
57.              ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy wb1.Worksheets(x(k1)).[a1]
    
58.             d.items()(k1).Copy wb1.Worksheets(x(k1)).Cells(hlrow + 1, 1)
    
59.             If bb = 7 Then
    
60.             zdRow = Selection.SpecialCells(xlCellTypeLastCell).Row
    
61.             qsh = lastRow - Val(bwhs) + 1
    
62.             ThisWorkbook.Worksheets(1).Rows(qsh & ":" & lastRow + 1).Copy ActiveSheet.Cells(zdRow + 1, 1)
    
63.             Else
    
64.             End If
    
65.             k1 = k1 + 1
    
66.             i = i + 1
    
67.         Next k
    
68.     End If
    
69.    
    
70.     For k = 0 To UBound(x)
    
71.       
    
72.         If cuttype = 2 Then
    
73.             Application.SheetsInNewWorkbook = 1
    
74.             Set wb = Workbooks.Add
    
75.             With wb.Worksheets(1)
    
76.                 ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy .[a1]
    
77.                 d.items()(k).Copy .Cells(hlrow + 1, 1)
    
78.                  If bb = 7 Then
    
79.             zdRow = Selection.SpecialCells(xlCellTypeLastCell).Row
    
80.             qsh = lastRow - Val(bwhs) + 1
    
81.             ThisWorkbook.Worksheets(1).Rows(qsh & ":" & lastRow + 1).Copy ActiveSheet.Cells(zdRow + 1, 1)
    
82.             Else
    
83.             End If
    
84.                 wb.SaveAs Filename:=ThisWorkbook.Path & "" & x(k) & ".xls"
    
85.                 wb.Close
    
86.             End With
    
87.         End If
    
88.     Next k
    
89.     If cuttype = 3 Then
    
90.         wb1.SaveAs Filename:=ThisWorkbook.Path & "" & "拆分数据表.xls"
    
91.         wb1.Close False
    
92.     End If
    
93. 5:
    
94.     Application.DisplayAlerts = True
    
95.     Application.ScreenUpdating = True
    
96.     MsgBox "拆分完毕！"
    
97.    
    
98. End Sub
    

复制代码

cjc209

不知你们都是怎么看的

cjc209

自己多动动脑筋啊

cjc209

什么才叫工具   不能应用于实际工作的叫工具吗？？？

cjc209

我发的可以不管你好多条件 只要不超过字段名的都可以作为拆分工作表条件 一个也可以 就只需你动动鼠或者输入数字就行了