如何统计缺考人数

sdytsxd991122

lushang2018

lushang2018

Sub 测试()
    Dim i%, j%, k%, m%, n%, arr, brr, s$, drr
    Dim dic As Object, key, keys, items
    Set dic = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("A1:M" & Sheet1.Cells(Rows.Count, "B").End(xlUp).Row)
    For i = 2 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            If arr(i, j) = "" Then
                If InStr(arr(i, 13) & "语数英", Left(arr(1, j), 1)) > 0 Then
                    key = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)
                    s = s & "," & arr(1, j)
                    dic(key) = s
                End If
            End If
        Next
        s = ""
    Next
    keys = dic.keys
    ReDim brr(1 To dic.Count + 1, 1 To 4)
    brr(1, 1) = "班级": brr(1, 2) = "缺考考号"
    brr(1, 3) = "缺考姓名": brr(1, 4) = "科目"
    For i = LBound(keys) To UBound(keys)
        key = keys(i)
        brr(2 + i, 1) = Split(key, ",")(0)
        brr(2 + i, 2) = Split(key, ",")(1)
        brr(2 + i, 3) = Split(key, ",")(2)
        brr(2 + i, 4) = Mid(dic.items()(i), 2)
    Next
    Sheet1.Range("O1").Resize(dic.Count + 1, 4) = brr
End Sub

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr, i&, j&, r&, dic As Object, iPosCol&, strTemp$
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion.Value
    ReDim br(1 To UBound(ar), 1 To 4)
    cr = Split("班级 缺考考号 缺考姓名 科目")
    For j = 0 To UBound(cr)
        br(1, j + 1) = cr(j)
    Next j
    r = 1
   
    For i = 2 To UBound(ar)
        For j = 7 To UBound(ar, 2) - 1
            If j = 8 Then
                dic(Mid(ar(1, j), 2, 1)) = j
            Else
                dic(Mid(ar(1, j), 1, 1)) = j
            End If
        Next j
        
        strTemp = ""
        For j = 1 To Len(ar(i, UBound(ar, 2)))
            iPosCol = dic(Mid(ar(i, UBound(ar, 2)), j, 1))
            If Len(ar(i, iPosCol)) = False Then
                If strTemp = "" Then
                    strTemp = ar(1, iPosCol)
                Else
                    strTemp = strTemp & "," & ar(1, iPosCol)
                End If
            End If
        Next j
        For j = 4 To 6
             If Len(ar(i, j)) = False Then
                If strTemp = "" Then
                    strTemp = ar(1, j)
                Else
                    strTemp = strTemp & "," & ar(1, j)
                End If
            End If
        Next j
        If Len(strTemp) Then
            r = r + 1
            For j = 1 To 3
                br(r, j) = ar(i, j)
            Next j
            br(r, 4) = strTemp
        End If
    Next i
   
    [O1].CurrentRegion.Clear
    [O1].Resize(r, 4) = br
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。

戎马书生222

cidanji 发表于 2024-7-17 15:12

你的代码。张锦泽的不对

Qs18

Public Sub qs() '2024/7/17
Dim arr, i, dic
Set dic = CreateObject("scripting.dictionary")
With Sheet1
    arr = .Range("a1").CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To 4)
    ReDim crr(1 To UBound(arr), 1 To 4)
For j = 2 To UBound(arr)
    t = "语" & "," & "数" & "," & "英"
        For i = 1 To 3
            t = t & "," & Mid(arr(j, 13), i, 1)
        Next
        tr = Split(t, ",")
        For y = 0 To UBound(tr)
            If tr(y) = "史" Then tr(y) = "历"
            For cl = 4 To UBound(arr, 2)
                If Left(arr(1, cl), 1) = tr(y) Then
                    If arr(j, cl) = Empty Then
                        m = m + 1
                        brr(m, 1) = arr(j, 1)
                        brr(m, 2) = arr(j, 2)
                        brr(m, 3) = arr(j, 3)
                        brr(m, 4) = brr(m, 4) & "," & arr(1, cl)
                    
                    End If
               
                End If
            Next
        Next
    t = ""
Next j
For n = 1 To m
    s = brr(n, 1) & brr(n, 2) & brr(n, 3)
    If Not dic.exists(s) Then
        Z = Z + 1
        dic(s) = Z
        crr(Z, 1) = brr(n, 1): crr(Z, 2) = brr(n, 2): crr(Z, 3) = brr(n, 3): crr(Z, 4) = Mid(brr(n, 4), 2)
    Else
        rz = dic(s): crr(rz, 4) = crr(rz, 4) & brr(n, 4)
    End If
Next
.Range("o2").Resize(Z, 4) = crr
End With
MsgBox "完成！"
End Sub

Qs18

试一下......

Qs18

试试...........

limonet

关键字：IIF