如何根据原始表关键列班级类型学科生成目标表

yzyyyyyyy

原始表：关键列，班级（多个），类型（多个），学科（多个）

目标表：根据原始表，分别统计各班级、各类型人数 如何根据原始表关键列班级类型学科生成目标表.rar (3.81 KB, 下载次数: 25)

2024-11-19 11:36 上传

点击文件名下载附件

shiruiqiang

字典，然后判读，分别写入各列

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("原始表").UsedRange
    For j = 2 To UBound(arr)
        If Not d.exists(arr(j, 1)) Then
            Set d(arr(j, 1)) = CreateObject("scripting.dictionary")
        End If
        If arr(j, 8) <> "单科状元" Then
            d(arr(j, 1))(arr(j, 8)) = d(arr(j, 1))(arr(j, 8)) + 1
        Else
            d(arr(j, 1))(arr(j, 9)) = d(arr(j, 1))(arr(j, 9)) + 1
        End If
    Next j
    Sheets("目标表1").UsedRange.Offset(2, 1).ClearContents
    arr = Sheets("目标表1").UsedRange
    For j = 4 To UBound(arr)
        For i = 3 To 4
            arr(j, i) = Val(d(arr(j, 1))(arr(1, i)))
            arr(3, i) = arr(j, i) + arr(3, i)
            arr(3, 2) = arr(j, i) + arr(3, 2)
            arr(j, 2) = arr(j, i) + arr(j, 2)
        Next i
        For i = 6 To 10
            arr(j, i) = Val(d(arr(j, 1))(arr(2, i)))
            arr(3, i) = arr(j, i) + arr(3, i)
            arr(3, 2) = arr(j, i) + arr(3, 2)
            arr(3, 5) = arr(j, i) + arr(3, 5)
            arr(j, 5) = arr(j, i) + arr(j, 5)
            arr(j, 2) = arr(j, i) + arr(j, 2)
        Next i
    Next j
    Sheets("目标表1").UsedRange = arr
    Sheets("目标表2").UsedRange.Offset(1, 1).ClearContents
    arr = Sheets("目标表2").UsedRange
    brr = Array("语文", 0, "数学", 0, "英语", 0, "物理", 0, "政治", 0)
    For j = 3 To UBound(arr)
        arr(j, 3) = Val(d(arr(j, 1))(arr(1, 3)))
        arr(j, 4) = Val(d(arr(j, 1))(arr(1, 4)))
        sm = 0
        str1 = ""
        For i = 0 To UBound(brr) Step 2
            k = brr(i)
            brr(i + 1) = brr(i + 1) + Val(d(arr(j, 1))(k))
            sm = sm + Val(d(arr(j, 1))(k))
            str1 = str1 & "；" & k & Val(d(arr(j, 1))(k)) & "人"
        Next
        arr(j, 2) = sm + arr(j, 3) + arr(j, 4)
        arr(2, 2) = arr(2, 2) + arr(j, 2)
        arr(2, 3) = arr(2, 3) + arr(j, 3)
        arr(2, 4) = arr(2, 4) + arr(j, 4)
        arr(j, 5) = sm & "人，其中，" & Mid(str1, 2)
    Next j
    str1 = ""
    sm = 0
    For i = 0 To UBound(brr) Step 2
        k = brr(i)
        sm = sm + brr(i + 1)
        str1 = str1 & "；" & k & brr(i + 1) & "人"
    Next
    arr(2, 5) = sm & "人，其中，" & Mid(str1, 2)
    Sheets("目标表2").UsedRange = arr
End Sub

liulang0808

代码有些啰嗦，楼主自己调整下吧

z865593849

汇总成绩

蓝桥玄霜

班级的例子：

yynrzwh

usedrange

做了一个目标。。。。。。

yzyyyyyyy

yynrzwh 发表于 2024-11-19 15:42

谢谢大师。抄写了大师的代码，人数、百颗星、进步星未统计出来，不知哪里抄错了 如何根据原始表关键列班级类型学科生成目标表.rar (11.42 KB, 下载次数: 1)

2024-11-19 16:45 上传

点击文件名下载附件

yynrzwh

yzyyyyyyy 发表于 2024-11-19 16:45
谢谢大师。抄写了大师的代码，人数、百颗星、进步星未统计出来，不知哪里抄错了

Sub test()

Set d = VBA.CreateObject("scripting.dictionary")
ar = Sheet1.Range("a1").CurrentRegion
For i = 2 To UBound(ar)
    s = ar(i, 1)
    If Not d.exists(s) Then
        Set d(s) = VBA.CreateObject("scripting.dictionary")
    End If
    If InStr(ar(i, 8), "状元") > 0 Then
        ss = ar(i, 8) & ar(i, 9)
        d(s)("单科状元小计") = d(s)("单科状元小计") + 1
    Else
        ss = ar(i, 8)
    End If
    d(s)(ss) = d(s)(ss) + 1
    d(s)("人数") = d(s)("人数") + 1
Next

'目标1
With Sheet2
    .Range("a3").CurrentRegion.Offset(2) = ""
    .Range("a5") = "合计"
    br = .Range("a3").Resize(d.Count + 3, 10)
    r = 3
    For Each k In d.keys
        r = r + 1
        br(r, 1) = k
        For j = 2 To UBound(br, 2)
            If br(1, j) <> "单科状元" And br(1, j) <> "" Then
                s = br(1, j)
            Else
                s = "单科状元" & br(2, j)
            End If
            If d(k).exists(s) Then br(r, j) = d(k)(s) Else br(r, j) = 0
            br(3, j) = br(3, j) + br(r, j)
        Next
    Next
    .Range("a3").Resize(d.Count + 3, 10) = br
    .Range("a6").Resize(d.Count, 10).Sort .[a6], Header:=xlNo
    cr = .Range("a3").Resize(d.Count + 3, 10)
End With

'目标2
    For j = 1 To 5
        cr(2, j) = cr(1, j)
    Next
   
    For i = 3 To UBound(cr)
        s = cr(i, 5) & "人，其中"
        For j = 6 To UBound(cr, 2)
            s = s & "；" & cr(2, j) & cr(i, j) & "人"
        Next
        cr(i, 5) = Replace(s, "其中；", "其中，")
    Next
   
With Sheet3
    .UsedRange.ClearContents
    .Range("a2").Resize(UBound(cr), 5) = cr
    .Rows(2).Clear
End With

End Sub