如何在结果中算出差值

于箱长

ykcbf1100 发表于 2024-2-22 15:52
稍等一下，我一会写一个。

感谢草爷的小花花，我写的思路是，建一个4*6的数组，然后把”估分"写入数组，再把数组存入字典，然后用”实考“调取字典里的数组，再把"实考"数据写入数组，并对比出差异，再把数组存入字典，然后在”结果“表中疯狂输出

ykcbf1100

zzpsx 发表于 2024-2-22 13:59
谢谢高手！很赞的代码。
实际情况中，结果这张sheet是空白。希望能点击按钮后在结果中出现截图所示的所 ...

改好了，结果表全自动生成。

ykcbf1100

更新后代码。。。

1. Sub ykcbf()   '//2024.2.22
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("Sheet1")
   
6.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
7.         arr = .[a1].Resize(r, 22)
   
8.         zrr = .[c1:g1]
   
9.     End With
   
10.     For i = 2 To UBound(arr)
    
11.         s = arr(i, 2)
    
12.         d(s) = i
    
13.     Next
    
14.     On Error Resume Next
    
15.     ReDim brr(1 To 10000, 1 To 6)
    
16.     With Sheets("结果")
    
17.         .Cells.Clear
    
18.         For Each k In d.keys
    
19.             m = m + 5
    
20.             brr(m - 4, 1) = k
    
21.             For y = 2 To 6
    
22.                 brr(m - 4, y) = zrr(1, y - 1)
    
23.             Next
    
24.             brr(m - 3, 1) = "估分"
    
25.             brr(m - 2, 1) = "实考"
    
26.             brr(m - 1, 1) = "差值"
    
27.             For j = 2 To 6
    
28.                 brr(m - 3, j) = arr(d(k), j + 1)
    
29.                 brr(m - 2, j) = arr(d(k), j + 12)
    
30.                 brr(m - 1, j) = arr(d(k), j + 1) - arr(d(k), j + 12)
    
31.             Next
    
32.         Next
    
33.         With .[a1].Resize(m, 6)
    
34.             .Value = brr
    
35.             .Borders.LineStyle = 1
    
36.             .HorizontalAlignment = xlCenter
    
37.             .VerticalAlignment = xlCenter
    
38.         End With
    
39.     End With
    
40.     Set d = Nothing
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    

复制代码

ykcbf1100

于箱长 发表于 2024-2-22 16:11
感谢草爷的小花花，我写的思路是，建一个4*6的数组，然后把”估分"写入数组，再把数组存入字典，然后用” ...

不错的思路，亮一下你的成果吧。

zzpsx

ykcbf1100 发表于 2024-2-22 16:13
改好了，结果表全自动生成。

谢谢高手，太厉害了。

在您的代码上，我修改了下：

Sub ykcbf()   '//2024.2.22
    Dim arr, d
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1")
        r = .Cells(.Rows.Count, "a").End(xlUp).Row
        arr = .[a1].Resize(r, 22)
        zrr = .[c1:g1]
    End With
    For i = 2 To UBound(arr)
        s = arr(i, 2)
        d(s) = i
    Next
    On Error Resume Next
    ReDim brr(1 To 10000, 1 To 6)
    With Sheets("结果")
        .Cells.Clear
        For Each k In d.keys
            m = m + 5
            brr(m - 4, 1) = k
            For y = 2 To 6
                brr(m - 4, y) = zrr(1, y - 1)
            Next
            brr(m - 3, 1) = "估分"
            brr(m - 2, 1) = "实考"
            brr(m - 1, 1) = "差值"
            For j = 2 To 6
                brr(m - 3, j) = arr(d(k), j + 1)
                brr(m - 2, j) = arr(d(k), j + 12)
                brr(m - 1, j) = arr(d(k), j + 12) - arr(d(k), j + 1) '修改此行代码，将减法顺序调整为先减后加
            Next
        Next
        With .[a1].Resize(m, 6)
            .Value = brr
            .Borders.LineStyle = 1
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    End With
    Set d = Nothing
    Application.ScreenUpdating = True
    MsgBox "OK！"
End Sub

cidanji

于箱长 发表于 2024-2-22 16:11
感谢草爷的小花花，我写的思路是，建一个4*6的数组，然后把”估分"写入数组，再把数组存入字典，然后用” ...

乡长，这样
建一个4*6的数组，然后把”估分"、“实考”、“差异”写入数组，数组存入字典，最后把字典存入数组输出

fzxba

1. Sub test0() '假定 蓝区 与 绿区 标题一致 且 姓名排序一致
   
2.   
   
3.   Dim ar(1), br(), cr
   
4.   Dim i As Long, j As Long, r As Long, c As Long
   
5.   
   
6.   c = 6
   
7.   With Sheet1
   
8.     For j = 0 To UBound(ar)
   
9.       ar(j) = .Cells(1, 1 + j * 11).CurrentRegion.Offset(, 1).Resize(, 6).Value
   
10.     Next
    
11.   End With
    
12.   ReDim br(1 To UBound(ar(0)) * 5, 1 To c)
    
13.   cr = Split("估分 实考 差值")
    
14.   
    
15.   For i = 2 To UBound(ar(0))
    
16.     r = r + 1
    
17.     br(r, 1) = ar(0)(i, 1)
    
18.     For j = 2 To UBound(br, 2)
    
19.       br(r, j) = ar(0)(1, j)
    
20.     Next
    
21.     r = r + 1
    
22.     For j = 0 To 2
    
23.       br(r + j, 1) = cr(j)
    
24.       If j < 2 Then
    
25.         For c = 2 To UBound(br, 2)
    
26.           br(r + j, c) = ar(j)(i, c)
    
27.           br(r + 2, c) = br(r + 1, c) - br(r, c)
    
28.         Next
    
29.       End If
    
30.     Next
    
31.     r = r + j
    
32.   Next
    
33.   
    
34.   With Sheet2
    
35.     .UsedRange.Clear
    
36.     With .Range("A1").Resize(r - 1, UBound(br, 2))
    
37.       .Borders.LineStyle = xlContinuous
    
38.       .HorizontalAlignment = xlCenter
    
39.       .Value = br
    
40.     End With
    
41.   End With
    
42.   
    
43.   Beep
    
44. End Sub

复制代码

fzxba

纯数组格式一致可用.zip (30.13 KB, 下载次数: 6)

2024-2-22 17:54 上传

点击文件名下载附件

zzpsx

问题已经解决，谢谢各位。

于箱长

ykcbf1100 发表于 2024-2-22 16:14
不错的思路，亮一下你的成果吧。