如何根据原始表关键列准考证号科目校验统计标色背景

yzyyyyyyy

原始表：关键列准考证号，科目。数据从上到下无规律乱序。

以关键列准考证号+科目，统计从上到下序号；复查科目明细；次数大于等于2的明细，背景显示黄色。
以关键列准考证号，统计复查科目数 如何根据原始表关键列准考证号科目校验统计标色背景.rar (2.7 KB, 下载次数: 13)

2023-7-8 10:31 上传

点击文件名下载附件

chxw68

能把简单问题设计得非常复杂也算水平。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr, crr(), drr()
   
4.     Dim d As Object
   
5.     Dim rng As Range
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     With Worksheets("原始表")
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         .Range("a2:f" & r).Interior.ColorIndex = 0
   
10.         arr = .Range("a2:f" & r)
    
11.         For i = 1 To UBound(arr)
    
12.             If Not d.exists(arr(i, 2)) Then
    
13.                 Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
14.             End If
    
15.             If Not d(arr(i, 2)).exists(arr(i, 4)) Then
    
16.                 m = 1
    
17.                 ReDim brr(1 To m)
    
18.             Else
    
19.                 brr = d(arr(i, 2))(arr(i, 4))
    
20.                 m = UBound(brr) + 1
    
21.                 ReDim Preserve brr(1 To m)
    
22.             End If
    
23.             brr(m) = i
    
24.             d(arr(i, 2))(arr(i, 4)) = brr
    
25.         Next
    
26.         For Each aa In d.keys
    
27.             ReDim crr(1 To 3)
    
28.             y = 0
    
29.             s = 1
    
30.             For Each bb In d(aa).keys
    
31.                 brr = d(aa)(bb)
    
32.                 For i = 2 To UBound(brr)
    
33.                     .Cells(brr(i) + 1, 1).Resize(1, 6).Interior.ColorIndex = 6
    
34.                 Next
    
35.                 For i = 1 To UBound(brr)
    
36.                     arr(brr(i), 6) = i
    
37.                 Next
    
38.                 crr(1) = crr(1) + UBound(brr)
    
39.                 crr(2) = crr(2) & ";" & bb & UBound(brr)
    
40.                 If UBound(brr) > 1 Then
    
41.                     crr(3) = crr(3) & ";" & aa & "," & bb & "," & UBound(brr) & "(" & Join(brr, ",") & ")"
    
42.                 End If
    
43.                 If UBound(brr) > 1 Then
    
44.                     y = y + 1
    
45.                     ReDim Preserve drr(1 To y)
    
46.                     drr(y) = Array(s, Len(bb) + Len(CStr(UBound(brr))))
    
47.                 End If
    
48.                 s = s + Len(bb) + Len(CStr(UBound(brr))) + 1
    
49.                
    
50.             Next
    
51.             If Len(crr(2)) <> 0 Then
    
52.                 crr(2) = Mid(crr(2), 2)
    
53.             End If
    
54.             If Len(crr(3)) <> 0 Then
    
55.                 crr(3) = Mid(crr(3), 2)
    
56.             End If
    
57.             m = d(aa).items()(0)(1) + 1
    
58.             .Cells(m, 7).Resize(1, UBound(crr)) = crr
    
59.             If y > 0 Then
    
60.                 For k = 1 To UBound(drr)
    
61.                     .Cells(m, 8).Characters(Start:=drr(k)(0), Length:=drr(k)(1)).Font.ColorIndex = 3
    
62.                 Next
    
63.             End If
    
64. 
    
65.                     
    
66.         Next
    
67.         .Range("f2").Resize(UBound(arr), 1) = Application.Index(arr, 0, 6)
    
68.     End With
    
69. End Sub
    

复制代码

chxw68

我也整个复杂的。