16个班能批量实现多个操作

yoshuya

有年级总表和16个班的子表
要的效果
16个班能批量实现

1	按考号升序排列
2	添加班级一列（班号为工作表数）
3	删除最下方 “全班”一行

谢谢！！！！！！！！！

求批量处理.rar (37.35 KB, 下载次数: 27)

2018-9-5 10:44 上传

点击文件名下载附件

liujialin0o0

1. Sub tt()
   
2. For Each sh In Sheets
   
3.     If IsNumeric(sh.Name) Then
   
4.         sh.Activate
   
5.         [H1] = "banji"
   
6.         n = Cells(Rows.Count, 1).End(3).Row - 1
   
7.         Range(Cells(2, 8), Cells(n, 8)) = sh.Name
   
8.         Cells(n + 1, 1).EntireRow.Delete
   
9.         Rows(1).AutoFilter
   
10.         sh.AutoFilter.Sort.SortFields.Clear
    
11.         sh.AutoFilter.Sort.SortFields.Add Key:=Range("G1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
12.         With sh.AutoFilter.Sort
    
13.             .Header = xlYes
    
14.             .MatchCase = False
    
15.             .Orientation = xlTopToBottom
    
16.             .SortMethod = xlPinYin
    
17.             .Apply
    
18.         End With
    
19.         Rows(1).AutoFilter
    
20.     End If
    
21. Next
    
22. End Sub

复制代码

yoshuya

liujialin0o0 发表于 2018-9-5 13:06

yoshuya

朱荣兴 发表于 2018-9-5 11:26
直接拆分即可，多少个班级无所谓的，
Sub chaifen()
Application.ScreenUpdating = False

测试通过，谢谢
下方工作表顺序是乱的
如果下方工作表能按1-16排序就完美了。


各列的数据能这样排列吗？


谢谢

liujialin0o0

yoshuya 发表于 2018-9-5 14:09

第2行前插入一行以下代码
dim n%,sh as worksheet

yoshuya

liujialin0o0 发表于 2018-9-5 14:37
第2行前插入一行以下代码
dim n%,sh as worksheet

还是不行，不过还得谢谢你。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   sx = [{"班级","考号","姓名","性别","语文","数学","英语","总分"}]
   
10.   For k = 1 To UBound(sx)
    
11.     d1(sx(k)) = k
    
12.   Next
    
13.   With Worksheets("全体名单")
    
14.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
15.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
16.     arr = .Range("a1").Resize(r, c)
    
17.     .Cells.Clear
    
18.     For j = 1 To UBound(arr, 2)
    
19.       If d1.exists(arr(1, j)) Then
    
20.         n = d1(arr(1, j))
    
21.         .Cells(1, n).Resize(UBound(arr), 1) = Application.Index(arr, 0, j)
    
22.       End If
    
23.     Next
    
24.     .Range("a1").Resize(r, c).Sort key1:=.Range("b2"), order1:=xlAscending, Header:=xlYes
    
25.     For i = 2 To UBound(arr)
    
26.       If Not d.exists(arr(i, 1)) Then
    
27.         Set d(arr(i, 1)) = .Range("a1:h1")
    
28.       End If
    
29.       Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 8))
    
30.     Next
    
31.   End With
    
32.   brr = d.keys
    
33.   For i = 0 To UBound(brr) - 1
    
34.     p = i
    
35.     For j = i + 1 To UBound(brr)
    
36.       If Val(brr(p)) > Val(brr(j)) Then
    
37.         p = j
    
38.       End If
    
39.     Next
    
40.     If p <> i Then
    
41.       temp = brr(i)
    
42.       brr(i) = brr(p)
    
43.       brr(p) = temp
    
44.     End If
    
45.   Next
    
46.   For k = 0 To UBound(brr)
    
47.     wjm = CStr(brr(k))
    
48.     On Error Resume Next
    
49.     Set ws = Worksheets(wjm)
    
50.     If Err Then
    
51.       Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
52.       ws.Name = wjm
    
53.     End If
    
54.     On Error GoTo 0
    
55.     With Worksheets(wjm)
    
56.       .Cells.Clear
    
57.       d(brr(k)).Copy .Range("a1")
    
58.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
59.       .Range("a1").Resize(r, c).Borders.LineStyle = xlContinuous
    
60.       With .UsedRange
    
61.         .HorizontalAlignment = xlCenter
    
62.         .VerticalAlignment = xlCenter
    
63.       End With
    
64.     End With
    
65.   Next
    
66. End Sub

复制代码

chxw68

按朱版主思路写的，所有分表都是重新生成的，与班级数量没有关系。

yoshuya

chxw68 发表于 2018-9-5 14:53
按朱版主思路写的，所有分表都是重新生成的，与班级数量没有关系。

完美解决，谢谢。
在哪送花，找了半天，没找到