如何在黄区算出实考减去估分，没估分的填写不够认真

zzpsx

如何在黄区算出实考减去估分，没估分的填写不够认真.rar (12.21 KB, 下载次数: 9)

2022-1-30 10:45 上传

点击文件名下载附件

之前的提问估计太啰嗦了，我简化了前期工作，把实考分和估分放在一张表格中。
蓝色为实考分，绿色为估分，有些学生没估分。
想在黄区算出差值，（每个学生之间有个空行，便于打印后裁剪）。差值就是实考分-估分。
有些学生没有估分，则在他们的差值上写不够认真。

3190496160

Sub test()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:j" & r)
    rs = .Cells(Rows.Count, 12).End(xlUp).Row
    br = .Range("l1:q" & r)
End With
ReDim arr(1 To UBound(ar) * 10, 1 To UBound(br, 2))
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(Trim(ar(i, 1))) = i
    End If
Next i
For i = 2 To UBound(br)
    If Trim(br(i, 1)) <> "" Then
        n = n + 5
        arr(n - 4, 1) = br(i, 1)
        For j = 2 To UBound(br, 2)
            arr(n - 4, j) = br(1, j)
        Next j
        arr(n - 3, 1) = "估分"
        For j = 2 To UBound(br, 2)
            arr(n - 3, j) = br(i, j)
        Next j
        arr(n - 2, 1) = "实考"
        xh = d(Trim(ar(i, 1)))
        If xh <> "" Then
            For j = 3 To 7
                arr(n - 2, j - 1) = ar(i, j)
            Next j
        End If
        arr(n - 1, 1) = "差值"
        For j = 2 To UBound(arr, 2)
            If Not IsNumeric(arr(n - 3, j)) Then
                arr(n - 1, j) = "不够认真"
            Else
                arr(n - 1, j) = arr(n - 2, j) - arr(n - 3, j)
            End If
        Next j
    End If
Next i
With Sheets("结果")
    .UsedRange.Clear
    .[a1].Resize(n, UBound(arr, 2)) = arr
End With
MsgBox "ok!"
End Sub

3190496160

如何在黄区算出实考减去估分，没估分的填写不够认真.rar (27.04 KB, 下载次数: 18)

2022-1-30 11:34 上传

点击文件名下载附件

准提部林

估分/實考/差值:
Sub TEST_A1()
Dim Arr, Brr, Crr, xD, R&, i&, j%, V1, V2, T$, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range(Sheet1.[Q1], Sheet1.[L65536].End(3))
For i = 2 To UBound(Arr)
    xD(Arr(i, 1)) = i
Next i
Brr = Range(Sheet1.[G1], Sheet1.[B65536].End(3))
ReDim Crr(1 To UBound(Brr) * 5, 1 To 6)
For i = 2 To UBound(Brr)
    R = xD(Brr(i, 1)): If R = 0 Then R = 1
    For j = 1 To 6
        V1 = Val(Arr(R, j)): V2 = Val(Brr(i, j))
        Crr(N + 1, j) = IIf(j = 1, Brr(i, j), Brr(1, j))
        Crr(N + 2, j) = IIf(j = 1, "估分", IIf(V1 = 0, "-", V1))
        Crr(N + 3, j) = IIf(j = 1, "实考", V2)
        Crr(N + 4, j) = IIf(j = 1, "差值", IIf(V1 = 0, "不够认真", V2 - V1))
    Next j
    N = N + 5
Next i
Sheet2.[a:f].ClearContents
Sheet2.[a1].Resize(N, 6) = Crr
End Sub

longming3

Sub tq()
    '实考
    m = Range("a65536").End(3).Row
    ar = Range("a1").Resize(m, 10)
    Set d2 = CreateObject("Scripting.Dictionary")
    For i = 1 To m
        gjz = ar(i, 2)
        d2(gjz) = Array(ar(i, 3), ar(i, 4), ar(i, 5), ar(i, 6), ar(i, 7))
    Next
    '估分
    m = Range("l65536").End(3).Row
    ar = Range("l1").Resize(m, 6)
    Set d1 = CreateObject("Scripting.Dictionary")
    For i = 1 To m
        gjz = ar(i, 1)
        d1(gjz) = Array(ar(i, 2), ar(i, 3), ar(i, 4), ar(i, 5), ar(i, 6))
    Next
    '数据
    m = Range("s65536").End(3).Row
    ar = Range("s1").Resize(m, 6)
    For i = 1 To m Step 5
        gjz = ar(i, 1)
        For j = 0 To 4
            ar(i + 1, j + 2) = d1(gjz)(j)
            ar(i + 2, j + 2) = d2(gjz)(j)
            If ar(i + 1, j + 2) = "-" Then
                ar(i + 3, j + 2) = "不够认真"
            Else
                ar(i + 3, j + 2) = ar(i + 1, j + 2) - ar(i + 2, j + 2)
            End If
        Next
    Next
    Range("z1").Resize(m, 6) = ar
End Sub

longming3

按要求先用两个字典记录两个区域数据，在一次性写入

zzpsx

谢谢各位的代码，用了两年多，很ok。
现在我想把蓝区定义为估分，绿区为实考，请问如何修改代码？