根据E列名称拆分工作表，并建立对应名称的工作表

quqiyuan

IE_Crayon

纯新手，参与一下

IE_Crayon

1. Option Explicit
   
2. 
   
3. Sub byz()
   
4.    
   
5.     Rem 定义行数i/h,列数x,计数器j/k/y
   
6.     Dim i, j, k, h, x, y
   
7.     Dim zb As Range
   
8.     Dim w As Worksheet, w1 As Worksheet
   
9.     Set w = Worksheets("总表")
   
10.     Rem 总表分类辅助区域
    
11.     For i = 3 To 16 Step 1
    
12.         
    
13.         k = 1
    
14.         
    
15.         Do While w.Cells(k, 10) <> w.Cells(i, 5) And w.Cells(k, 10) <> ""
    
16.         
    
17.             k = k + 1
    
18.             
    
19.         Loop
    
20.         
    
21.         If w.Cells(k, 10) = "" Then
    
22.             
    
23.             w.Cells(k, 10) = w.Cells(i, 5)
    
24.             j = j + 1
    
25.         
    
26.         End If
    
27.    
    
28.     Next i
    
29.    
    
30.     Rem 创建子表
    
31.     For h = 1 To j Step 1
    
32.    
    
33.         Set w1 = Worksheets.Add
    
34.         w1.Name = w.Cells(h, 10)
    
35.         Set zb = Range(w1.Cells(1, 1), w1.Cells(1, 8))
    
36.         Rem 合并表头
    
37.         zb.Select
    
38.         Selection.Merge
    
39.         With zb
    
40.             .Value = w1.Name
    
41.             .Font.Size = 14
    
42.             .Font.Bold = True
    
43.             .Font.Name = "宋体"
    
44.             .HorizontalAlignment = xlCenter
    
45.             .VerticalAlignment = xlCenter
    
46.         End With
    
47.    
    
48.         For x = 1 To 8 Step 1
    
49.         
    
50.             w.Cells(2, x).Copy
    
51.             w1.Cells(2, x).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
52.             Application.CutCopyMode = False
    
53.             
    
54.         Next x
    
55.         Rem 子表数据拆分
    
56.         y = 3
    
57.         For i = 3 To 16 Step 1
    
58.      
    
59.                 If w.Cells(i, 5) = w1.Name Then
    
60.                     
    
61.                     For x = 1 To 8 Step 1
    
62.                         
    
63.                         w.Cells(i, x).Copy
    
64.                         w1.Cells(y, x).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
65.                         Application.CutCopyMode = False
    
66.                         
    
67.                     Next x
    
68.                     
    
69.                     y = y + 1
    
70.                
    
71.                 End If
    
72.                
    
73.         Next i
    
74.    
    
75.     Next h
    
76.    
    
77.     Rem 删除辅助区域
    
78.     Range(w.Cells(1, 10), w.Cells(j, 10)).Clear
    
79.    
    
80. End Sub
    

复制代码