如何根据网上表和原有表关键字段生成统计表

yzyyyyyyy

原有表：关键列，报名状态（若是不报名，则未注册不包括这些学生）,班级/年级,姓名,身份证号（唯一字段）

网上表：关键列，注册状态,完善状态,报名状态,班级,姓名,身份证件号（唯一字段）
说明：网上表中的数据全部包含在原有表中，原有表报名状态为不报名为不报名，不注册；若报名状态为空白，则需统一为注册，若没在网上表，则为未注册。
如何根据原有表和网上表，生成统计表 如何根据网上表和原有表关键字段生成统计表.rar (6.05 KB, 下载次数: 16)

2023-3-20 20:13 上传

点击文件名下载附件

ykcbf1100

有点复杂。

ykcbf1100

体力活啊，今天完成了一个。

chxw68

统计表1的代码：

1. Sub test1() '统计表1
   
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.     With Worksheets("网上表")
   
10.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.         crr = .Range("a3:i" & r)
    
12.         For i = 1 To UBound(crr)
    
13.             d1(CStr(crr(i, 9))) = i
    
14.         Next
    
15.     End With
    
16.     With Worksheets("原有表")
    
17.         r = .Cells(.Rows.Count, 7).End(xlUp).Row
    
18.         arr = .Range("a2:i" & r)
    
19.         For i = 1 To UBound(arr)
    
20.             If Not d.exists(arr(i, 7)) Then
    
21.                 ReDim brr(1 To 22)
    
22.                 brr(1) = arr(i, 7)
    
23.             Else
    
24.                 brr = d(arr(i, 7))
    
25.             End If
    
26.             brr(3) = brr(3) + 1
    
27.             If arr(i, 1) = "不报名" Then
    
28.                 brr(4) = brr(4) + 1
    
29.                 brr(5) = brr(5) & "," & arr(i, 8)
    
30.             Else
    
31.                 If d1.exists(CStr(arr(i, 9))) Then
    
32.                     m = d1(arr(i, 9))
    
33.                     brr(6) = brr(6) + 1
    
34.                     brr(7) = brr(7) & "," & arr(i, 8)
    
35.                     brr(10) = brr(10) + 1
    
36.                     brr(11) = brr(11) + 1
    
37.                     brr(12) = brr(12) & "," & arr(i, 8)
    
38.                     If crr(m, 2) = "完善" Then
    
39.                         brr(13) = brr(13) + 1
    
40.                         brr(14) = brr(14) & "," & crr(m, 8)
    
41.                     Else
    
42.                         brr(15) = brr(15) + 1
    
43.                         brr(16) = brr(16) & "," & crr(m, 8)
    
44. 
    
45.                     End If
    
46.                     If crr(m, 3) = "未报名" Then
    
47.                         brr(17) = brr(17) + 1
    
48.                         brr(18) = brr(18) & "," & crr(m, 8)
    
49.                     Else
    
50.                         brr(19) = brr(19) + 1
    
51.                         brr(20) = brr(20) & "," & crr(m, 8)
    
52.                     End If
    
53.                 Else
    
54.                     brr(8) = brr(8) + 1
    
55.                     brr(9) = brr(9) & "," & arr(i, 8)
    
56.                 End If
    
57.             End If
    
58.             d(arr(i, 7)) = brr
    
59.         Next
    
60.     End With
    
61.     ReDim drr(1 To d.Count, 1 To UBound(brr))
    
62.     ReDim grr(1 To UBound(brr))
    
63.     m = 0
    
64.     For Each aa In d.keys
    
65.         brr = d(aa)
    
66.         For Each x In Array(5, 7, 9, 12, 14, 16, 18, 20)
    
67.             If Len(brr(x)) <> 0 Then
    
68.                 brr(x) = Mid(brr(x), 2)
    
69.             End If
    
70.         Next
    
71.         For Each x In Array(3, 4, 6, 8, 10, 11, 13, 15, 17, 19)
    
72.             grr(x) = grr(x) + brr(x)
    
73.         Next
    
74.         If brr(8) + brr(17) <> 0 Then
    
75.             brr(21) = brr(8) & "+" & brr(17) & "=" & brr(8) + brr(17)
    
76.         End If
    
77.         If Len(brr(9)) <> 0 Then
    
78.             brr(22) = brr(9)
    
79.         End If
    
80.         If Len(brr(18)) <> 0 Then
    
81.             brr(22) = brr(22) & "," & brr(18)
    
82.         End If
    
83.         If Len(brr(22)) <> 0 Then
    
84.             brr(22) = Mid(brr(22), 2)
    
85.         End If
    
86. 
    
87.         m = m + 1
    
88.         For j = 1 To UBound(brr)
    
89.             drr(m, j) = brr(j)
    
90.         Next
    
91.     Next
    
92.     grr(21) = grr(8) & "+" & grr(17) & "=" & grr(8) + grr(17)
    
93.     With Worksheets("统计表1")
    
94.         .Range("a6:v" & .Rows.Count).Clear
    
95.         .Range("a6").Resize(1, UBound(grr)) = grr
    
96.         .Range("a7").Resize(UBound(drr), UBound(drr, 2)) = drr
    
97.         With .Range("a3").Resize(3 + 1 + UBound(drr), UBound(drr, 2))
    
98.             .Borders.LineStyle = xlContinuous
    
99.             With .Font
    
100.                 .Name = "微软雅黑"
     
101.                 .Size = 10
     
102.             End With
     
103.             .HorizontalAlignment = xlCenter
     
104.             .VerticalAlignment = xlCenter
     
105.         End With
     
106.     End With
     
107. End Sub
     

复制代码

chxw68

统计表2的代码：

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     With Worksheets("网上表")
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         crr = .Range("a3:i" & r)
   
10.         For i = 1 To UBound(crr)
    
11.             d1(CStr(crr(i, 9))) = i
    
12.         Next
    
13.     End With
    
14.     With Worksheets("原有表")
    
15.         r = .Cells(.Rows.Count, 7).End(xlUp).Row
    
16.         arr = .Range("a2:i" & r)
    
17.         For i = 1 To UBound(arr)
    
18.             If Not d.exists(arr(i, 7)) Then
    
19.                 ReDim brr(1 To 12)
    
20.                 brr(1) = arr(i, 7)
    
21.             Else
    
22.                 brr = d(arr(i, 7))
    
23.             End If
    
24.             brr(3) = brr(3) + 1
    
25.             If arr(i, 1) = "不报名" Then
    
26.                 brr(4) = brr(4) + 1
    
27.                 brr(5) = brr(5) & "," & arr(i, 8)
    
28.             End If
    
29.             If Not d1.exists(CStr(arr(i, 9))) Then
    
30.                 brr(6) = brr(6) + 1
    
31.                 brr(7) = brr(7) & "," & arr(i, 8)
    
32.             Else
    
33.                 m = d1(CStr(arr(i, 9)))
    
34.                 brr(8) = brr(8) + 1
    
35.                 If crr(m, 2) = "未完善" Then
    
36.                     brr(9) = brr(9) + 1
    
37.                     brr(10) = brr(10) & "," & crr(m, 8)
    
38.                 End If
    
39.                 If crr(m, 3) = "未报名" Then
    
40.                     brr(11) = brr(11) + 1
    
41.                     brr(12) = brr(12) & "," & crr(m, 8)
    
42.                 End If
    
43.             End If
    
44.             d(arr(i, 7)) = brr
    
45.         Next
    
46.     End With
    
47.    
    
48.     ReDim drr(1 To d.Count, 1 To UBound(brr))
    
49.     ReDim frr(1 To UBound(brr))
    
50.     frr(1) = "小计"
    
51.     m = 0
    
52.     For Each aa In d.keys
    
53.         brr = d(aa)
    
54.         For Each x In Array(5, 7, 10, 12)
    
55.             If Len(brr(x)) <> 0 Then
    
56.                 brr(x) = Mid(brr(x), 2)
    
57.             End If
    
58.         Next
    
59.         For Each x In Array(3, 4, 6, 8, 9, 11)
    
60.             frr(x) = frr(x) + brr(x)
    
61.         Next
    
62.         m = m + 1
    
63.         For j = 1 To UBound(brr)
    
64.             drr(m, j) = brr(j)
    
65.         Next
    
66.     Next
    
67.     With Worksheets("统计表2")
    
68.         .Range("a6:l" & .Rows.Count).Clear
    
69.         .Range("a6").Resize(1, UBound(frr)) = frr
    
70.         .Range("a7").Resize(UBound(drr), UBound(drr, 2)) = drr
    
71.         .Range("a7").Resize(UBound(drr), UBound(drr, 2)).Sort key1:=.Range("a7"), order1:=xlAscending, Header:=xlNo
    
72.         With .Range("a3").Resize(3 + 1 + UBound(drr), UBound(drr, 2))
    
73.             .Borders.LineStyle = xlContinuous
    
74.             With .Font
    
75.                 .Name = "微软雅黑"
    
76.                 .Size = 9
    
77.             End With
    
78.             .HorizontalAlignment = xlCenter
    
79.             .VerticalAlignment = xlCenter
    
80.         End With
    
81.         .Columns(1).Resize(, 12).AutoFit
    
82.     End With
    
83. End Sub
    

复制代码

chxw68

详见附件。