如何根据考场安排表缺考登记表和参数设置表模板生成各年级各学科分数登记条

yzyyyyyyy

分数登记过程中，出现这样的现象，即本应是缺考的，有的登记了分数，即登记分数错位。为了避免此类现象，登分前，把缺考和座号直接标出，未安排的座号为空白，缺考的分数直接显示为缺考。
考场安排表：试场号，地点，各年级人数
缺考登记：各年级，学科缺考的试场号，座号
参数设置：各年级，学科，是否生成登分条，若为是，则生成各年级登分条文件。 如何根据考场安排表缺考登记表和参数设置表模板生成各年级各学科分数登记条.rar (39.99 KB, 下载次数: 8)

2020-9-23 15:21 上传

点击文件名下载附件

3190496160

恕我直言，楼主这样来登记每次的考试成绩，不知道楼主后期是如何处理的，研究成绩分析好多年了，从来没见过如此等分的，

zpy2

如果要用电脑提高效率，格式流程可能是需要有所改变。

yzyyyyyyy

3190496160 发表于 2020-9-23 20:51
恕我直言，楼主这样来登记每次的考试成绩，不知道楼主后期是如何处理的，研究成绩分析好多年了，从来没见过 ...

打印出来，手工登记，再录入。

chxw68

1. Sub test99()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim lk(1 To 4)
   
5.   Dim d As Object
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   Set d = CreateObject("scripting.dictionary")
   
9.   Set d_cs = CreateObject("scripting.dictionary")
   
10.   Set d_qk = CreateObject("scripting.dictionary")
    
11.   Set d_kc = CreateObject("scripting.dictionary")
    
12.   With Worksheets("缺考登记")
    
13.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.     arr = .Range("a2:g" & r)
    
15.     For i = 1 To UBound(arr)
    
16.       arr(i, 2) = Replace(arr(i, 2), "，", ",")
    
17.       xm = Split(arr(i, 2), ",")
    
18.       For j = 0 To UBound(xm)
    
19.         If Not d_qk.exists(arr(i, 1)) Then
    
20.           Set d_qk(arr(i, 1)) = CreateObject("scripting.dictionary")
    
21.         End If
    
22.         If Not d_qk(arr(i, 1)).exists(xm(j)) Then
    
23.           Set d_qk(arr(i, 1))(xm(j)) = CreateObject("scripting.dictionary")
    
24.         End If
    
25.         If Not d_qk(arr(i, 1))(xm(j)).exists(arr(i, 3)) Then
    
26.           Set d_qk(arr(i, 1))(xm(j))(arr(i, 3)) = CreateObject("scripting.dictionary")
    
27.         End If
    
28.         d_qk(arr(i, 1))(xm(j))(arr(i, 3))(arr(i, 4)) = ""
    
29.       Next
    
30.     Next
    
31.   End With
    
32.   With Worksheets("考场安排")
    
33.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
34.     arr = .Range("a2:f" & r)
    
35.     For j = 3 To 5
    
36.       For i = 3 To UBound(arr)
    
37.         If Len(arr(i, j)) <> 0 And arr(i, j) <> 0 Then
    
38.           If Not d_kc.exists(arr(2, j)) Then
    
39.             Set d_kc(arr(2, j)) = CreateObject("scripting.dictionary")
    
40.           End If
    
41.           d_kc(arr(2, j))(arr(i, 1)) = Array(arr(i, 2), arr(i, j))
    
42.         End If
    
43.       Next
    
44.     Next
    
45.   End With
    
46.   With Worksheets("参数设置")
    
47.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
48.     arr = .Range("a2:c" & r)
    
49.     For i = 1 To UBound(arr)
    
50.       If arr(i, 3) = "是" Then
    
51.         If Not d.exists(arr(i, 1)) Then
    
52.           Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
53.         End If
    
54.         If Not d(arr(i, 1)).exists(arr(i, 2)) Then
    
55.           Set d(arr(i, 1))(arr(i, 2)) = CreateObject("scripting.dictionary")
    
56.         End If
    
57.         If d_kc.exists(arr(i, 1)) Then
    
58.           For Each bb In d_kc(arr(i, 1)).keys
    
59.             crr = d_kc(arr(i, 1))(bb)
    
60.             If Not d(arr(i, 1))(arr(i, 2)).exists(bb) Then
    
61.               Set d(arr(i, 1))(arr(i, 2))(bb) = CreateObject("scripting.dictionary")
    
62.             End If
    
63.             d(arr(i, 1))(arr(i, 2))(bb) = crr '年级+科目+试场
    
64.           Next
    
65.         End If
    
66.       End If
    
67.     Next
    
68.   End With
    
69.   With Worksheets("模板")
    
70.     For j = 1 To 4
    
71.       lk(j) = .Columns(j).ColumnWidth
    
72.     Next
    
73.     For Each aa In d.keys
    
74.       m = 1
    
75.       n = 1
    
76.       .Rows("26:" & .Rows.Count).Delete
    
77.       .Columns(5).Resize(, .Columns.Count - 4).Delete
    
78.       For i = 1 To 11 Step 5
    
79.         For j = 1 To 4
    
80.           .Columns(i + j - 1).ColumnWidth = lk(j)
    
81.         Next
    
82.         If i <> 11 Then
    
83.           .Columns(i + 4).ColumnWidth = 15.25
    
84.         End If
    
85.       Next
    
86.       For Each bb In d(aa).keys
    
87.         For Each cc In d(aa)(bb).keys
    
88.           If m <> 1 Or n <> 1 Then
    
89.             .Range("a1:d25").Copy .Cells(m, n)
    
90.           End If
    
91.           crr = d(aa)(bb)(cc)
    
92.           .Cells(m + 1, n + 1) = aa
    
93.           .Cells(m + 1, n + 3) = bb
    
94.           .Cells(m + 2, n + 1) = cc
    
95.           .Cells(m + 2, n + 3) = crr(0)
    
96.           .Cells(m + 4, n).Resize(20, 4).ClearContents
    
97.           For i = 1 To crr(1)
    
98.             .Cells(IIf(i <= 20, m + i + 3, m + i - 17), IIf(i <= 20, n, n + 2)) = i
    
99.             If d_qk.exists(aa) Then
    
100.               If d_qk(aa).exists(bb) Then
     
101.                 If d_qk(aa)(bb).exists(cc) Then
     
102.                   If d_qk(aa)(bb)(cc).exists(i) Then
     
103.                     .Cells(IIf(i <= 20, m + i + 3, m + i - 17), IIf(i <= 20, n + 1, n + 3)) = "缺考"
     
104.                   End If
     
105.                 End If
     
106.               End If
     
107.             End If
     
108.           Next
     
109.           n = n + 5
     
110.           If n > 11 Then
     
111.             n = 1
     
112.             m = m + 25
     
113.           End If
     
114.         Next
     
115.       Next
     
116.       .Copy
     
117.       With ActiveWorkbook
     
118.         .SaveAs Filename:=ThisWorkbook.Path & "" & aa & "登分卡"
     
119.         .Close False
     
120.       End With
     
121.     Next
     
122.   End With
     
123.   Application.ScreenUpdating = True
     
124.   MsgBox "登分卡生成完毕！"
     
125.       
     
126. End Sub
     

复制代码

chxw68

看似简单的问题，实则还比较复杂。

yzyyyyyyy

chxw68 发表于 2020-9-24 09:04
看似简单的问题，实则还比较复杂。

谢谢大师热心帮助，精确，高效，完美解决了日常考务中悬而难解的一大难题，向大师致敬，这里应该有掌声…………