如何根据原始表135列和班主任生成统计表和3个名单表20170618

yzyyyyyyy

原始表：第1列为填报状态(已填报,未填报)，第3列为班级，第5列为姓名
统计表：已填报，未填报各班人数；
全部名单：已填报姓名后无标记，未填报后打×，第4行为全部人数=已填报人数+未填报人数，如299=229+70
已填报名单、未填报名单
班主任：为各班级的班主任名单
目标：直接根据原始表生成名单及统计表 如何根据原始表135列和班主任生成统计表和3个名单表20170618.rar (26.81 KB, 下载次数: 22)

2017-6-18 09:57 上传

点击文件名下载附件

蓝桥玄霜

可以用字典套字典实现，建议搜索类似帖子。

LMY123

关注一下楼主的帖子

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set dcs = CreateObject("scripting.dictionary")
   
7.   With Worksheets("班主任")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a1:b" & r)
   
10.     For i = 1 To UBound(arr)
    
11.       xm = Format(arr(i, 1), "00")
    
12.       dcs(xm) = arr(i, 2)
    
13.     Next
    
14.   End With
    
15.   With Worksheets("原始表")
    
16.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
17.     arr = .Range("a3:e" & r)
    
18.     For i = 1 To UBound(arr)
    
19.       bj = Mid(arr(i, 3), 4, 2)
    
20.       If Not d.exists(bj) Then
    
21.         m = 4
    
22.         ReDim brr(1 To m)
    
23.         brr(1) = bj
    
24.         If dcs.exists(bj) Then
    
25.           brr(2) = dcs(bj)
    
26.         End If
    
27.         brr(3) = Array(0, 0)
    
28.       Else
    
29.         brr = d(bj)
    
30.         m = UBound(brr) + 1
    
31.         ReDim Preserve brr(1 To m)
    
32.       End If
    
33.       If arr(i, 1) = "已填报" Then
    
34.         brr(3)(0) = brr(3)(0) + 1
    
35.         brr(m) = arr(i, 5)
    
36.       Else
    
37.         brr(3)(1) = brr(3)(1) + 1
    
38.         brr(m) = arr(i, 5) & "×"
    
39.       End If
    
40.       d(bj) = brr
    
41.     Next
    
42.   End With
    
43.   With Worksheets("全部名单")
    
44.     .UsedRange.Offset(1, 0).Clear
    
45.     .Range("a2") = "班级"
    
46.     .Range("a3") = "班主任"
    
47.     n = 2
    
48.     For k = 1 To 15
    
49.       xm = Format(k, "00")
    
50.       If d.exists(xm) Then
    
51.         brr = d(xm)
    
52.         brr(3) = brr(3)(0) + brr(3)(1) & "=" & brr(3)(0) & "+" & brr(3)(1)
    
53.         crr = Application.Transpose(brr)
    
54.         .Cells(2, n).Resize(UBound(crr), 1) = crr
    
55.         n = n + 1
    
56.       End If
    
57.     Next
    
58.     r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
59.     For i = 4 To r
    
60.       .Cells(i, 1) = i - 3
    
61.     Next
    
62.   End With
    
63. End Sub
    

复制代码

chxw68

只写了生成“全部名单”的代码。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d(1 To 3) As Object
   
5.   Dim shnam
   
6.   shnam = [{"全部名单","已填报","未填报"}]
   
7.   For i = 1 To 3
   
8.     Set d(i) = CreateObject("scripting.dictionary")
   
9.   Next
   
10.   Set dcs = CreateObject("scripting.dictionary")
    
11.   With Worksheets("班主任")
    
12.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.     arr = .Range("a1:b" & r)
    
14.     For i = 1 To UBound(arr)
    
15.       xm = Format(arr(i, 1), "00")
    
16.       dcs(xm) = arr(i, 2)
    
17.     Next
    
18.   End With
    
19.   With Worksheets("原始表")
    
20.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
21.     arr = .Range("a3:e" & r)
    
22.     For i = 1 To UBound(arr)
    
23.       bj = Mid(arr(i, 3), 4, 2)
    
24.       If dcs.exists(bj) Then
    
25.         bzr = dcs(bj)
    
26.       Else
    
27.         bzr = ""
    
28.       End If
    
29.       If Not d(1).exists(bj) Then
    
30.         m = 4
    
31.         ReDim brr(1 To m)
    
32.         brr(1) = bj
    
33.         brr(2) = bzr
    
34.         brr(3) = Array(0, 0)
    
35.       Else
    
36.         brr = d(1)(bj)
    
37.         m = UBound(brr) + 1
    
38.         ReDim Preserve brr(1 To m)
    
39.       End If
    
40.       If arr(i, 1) = "已填报" Then
    
41.         brr(3)(0) = brr(3)(0) + 1
    
42.         brr(m) = arr(i, 5)
    
43.       Else
    
44.         brr(3)(1) = brr(3)(1) + 1
    
45.         brr(m) = arr(i, 5) & "×"
    
46.       End If
    
47.       d(1)(bj) = brr
    
48.     Next
    
49.   End With
    
50.   For Each aa In d(1).keys
    
51.     brr = d(1)(aa)
    
52.     ReDim crr(1 To UBound(brr))
    
53.     ReDim drr(1 To UBound(brr))
    
54.     For i = 1 To 2
    
55.       crr(i) = brr(i)
    
56.       drr(i) = brr(i)
    
57.     Next
    
58.     m = 3
    
59.     n = 3
    
60.     For i = 4 To UBound(brr)
    
61.       If Right(brr(i), 1) <> "×" Then
    
62.         m = m + 1
    
63.         crr(m) = brr(i)
    
64.         crr(3) = crr(3) + 1
    
65.       Else
    
66.         n = n + 1
    
67.         drr(n) = Left(brr(i), Len(brr(i)) - 1)
    
68.         drr(3) = drr(3) + 1
    
69.       End If
    
70.     Next
    
71.     d(2)(aa) = crr
    
72.     d(3)(aa) = drr
    
73.   Next
    
74.   For q = 1 To 3
    
75.     With Worksheets(shnam(q))
    
76.       .UsedRange.Offset(1, 0).Clear
    
77.       .Range("a2") = "班级"
    
78.       .Range("a3") = "班主任"
    
79.       n = 2
    
80.       For k = 1 To 15
    
81.         xm = Format(k, "00")
    
82.         If d(q).exists(xm) Then
    
83.           brr = d(q)(xm)
    
84.           If q = 1 Then
    
85.             brr(3) = brr(3)(0) + brr(3)(1) & "=" & brr(3)(0) & "+" & brr(3)(1)
    
86.           End If
    
87.           crr = Application.Transpose(brr)
    
88.           .Cells(2, n).Resize(UBound(crr), 1) = crr
    
89.           n = n + 1
    
90.         End If
    
91.       Next
    
92.       r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
93.       c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
94.       For i = 4 To r
    
95.         .Cells(i, 1) = i - 3
    
96.       Next
    
97.       .Range("a2").Resize(r - 1, c).Borders.LineStyle = xlContinuous
    
98.       With .UsedRange
    
99.         With .Font
    
100.           .Size = 10
     
101.         End With
     
102.         .HorizontalAlignment = xlCenter
     
103.         .VerticalAlignment = xlCenter
     
104.       End With
     
105.     End With
     
106.   Next
     
107. End Sub
     

复制代码

chxw68

生成全部名单、已填报、未填报三个表的代码。