如何统计缺考人数

戎马书生222

请高手给个思路，学习一下。

cidanji

3190496160

Sub 统计缺考()
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "数据源为空！": End
    ar = .Range("a1:m" & r)
    ReDim br(1 To UBound(ar), 1 To 4)
    For j = 7 To UBound(ar, 2) - 1
        If ar(1, j) <> "" Then
            If j = 8 Then
                zd = Right(ar(1, j), 1)
            Else
                zd = Left(ar(1, j), 1)
            End If
            d(zd) = j
        End If
    Next j
    For i = 2 To UBound(ar, 1)
        zf = ""
        If ar(i, 2) <> "" And ar(i, 13) <> "" Then
            For j = 4 To 6
                If ar(i, j) = "" Then
                    If zf = "" Then
                        zf = ar(1, j)
                    Else
                        zf = zf & "," & ar(1, j)
                    End If
                End If
            Next j
            For j = 1 To Len(ar(i, 13))
                zd = Mid(ar(i, 13), j, 1)
                lh = d(zd)
                If lh <> "" Then
                    If ar(i, lh) = "" Then
                        If zf = "" Then
                            zf = ar(1, lh)
                        Else
                            zf = zf & "," & ar(1, lh)
                        End If
                    End If
                End If
            Next j
            If zf <> "" Then
                n = n + 1
                For j = 1 To 3
                    br(n, j) = ar(i, j)
                Next j
                br(n, 4) = zf
            End If
        End If
    Next i
    .[o1].CurrentRegion.Offset(1) = Empty
    .[o2].Resize(n, 4) = br
End With
MsgBox "ok!"
End Sub

3190496160

工作簿1.rar (21.65 KB, 下载次数: 15)

2024-7-17 15:19 上传

点击文件名下载附件

longwin

Sub test()
    arr = [a1].CurrentRegion
    ReDim qrr(1 To 1000, 1 To 4)
    m = 0
    For i = 2 To UBound(arr)
        zh = arr(i, 13)
        zh = Replace(zh, "史", "历")
        zh = "语数英" & zh
        qk = ""
        For j = 4 To UBound(arr, 2) - 1
            If arr(i, j) = "" Then
                If InStr(1, zh, Left(arr(1, j), 1)) > 0 Then
                    qk = qk & "," & arr(1, j)
                End If
            End If
        Next
        If qk <> "" Then
            m = m + 1
            qrr(m, 1) = arr(i, 1)
            qrr(m, 2) = arr(i, 2)
            qrr(m, 3) = arr(i, 3)
            qrr(m, 4) = Right(qk, Len(qk) - 1)
        End If
    Next
    [O1].CurrentRegion.Offset(1, 0).ClearContents
    [O2].Resize(m, 4) = qrr
End Sub

lisongmei

代码审核中。。

lisongmei

Option Explicit

Sub test()
Dim arr, brr(1 To 10000, 1 To 4), dic, rs%, i%, sr$, j%, num%, x%
Set dic = CreateObject("scripting.dictionary")
rs = ThisWorkbook.Sheets("Sheet1").Range("b1000").End(xlUp).Row
For i = 2 To rs
    If Application.WorksheetFunction.Count(Range(Cells(i, 4), Cells(i, "L"))) <> 6 Then
        For j = 4 To 12
            If Cells(i, j) = 0 And InStr(Cells(i, "M") & "语数英", Left(Cells(1, j), 1)) > 0 Then
                sr = sr & Cells(1, j) & "，"
            End If
        Next
        dic(Cells(i, 1) & "|" & Cells(i, 2) & "|" & Cells(i, 3)) = Left(sr, Len(sr) - 1)
        sr = ""
    End If
Next
For x = 0 To dic.Count - 1
    num = num + 1
    arr = Split(dic.keys()(x), "|")
    brr(num, 1) = arr(0)
    brr(num, 2) = arr(1)
    brr(num, 3) = arr(2)
    brr(num, 4) = dic(dic.keys()(x))
Next
With ThisWorkbook.Sheets("Sheet1")
    .Range("o2:r10000").ClearContents
    .Range("o2").Resize(num, 4) = brr
End With
End Sub

usedrange

1. Sub t()
   
2.     Dim arr, brr, m%, i%, j%, dic, k, s, r%
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     m = Sheet1.[a1].End(4).Row
   
5.     arr = Sheet1.Range("a1").CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         For j = 4 To UBound(arr, 2) - 1
   
8.             If arr(i, j) = "" Then
   
9.                 If InStr(arr(i, 13), "物化") Then
   
10.                     If InStr(arr(i, 13), "生") And j <> 7 And j <> 8 And j <> 9 Then
    
11.                         dic(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) = dic(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) & arr(1, j) & "，"
    
12.                     ElseIf InStr(arr(i, 13), "地") And j <> 7 And j <> 12 And j <> 8 Then
    
13.                         dic(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) = dic(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) & arr(1, j) & "，"
    
14.                     End If
    
15.                 ElseIf InStr(arr(i, 13), "政史") Then
    
16.                     If InStr(arr(i, 13), "生") And j <> 10 And j <> 11 And j <> 9 Then
    
17.                         dic(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) = dic(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) & arr(1, j) & "，"
    
18.                     ElseIf InStr(arr(i, 13), "地") And j <> 10 And j <> 11 And j <> 12 Then
    
19.                         dic(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) = dic(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) & arr(1, j) & "，"
    
20.                     End If
    
21.                 End If
    
22.             End If
    
23.         Next j
    
24.     Next i
    
25.     ReDim brr(1 To m, 1 To 4)
    
26.     r = 1
    
27.     For Each k In dic.keys
    
28.         s = Split(k, "|")
    
29.         For i = 0 To UBound(s)
    
30.             brr(r, i + 1) = s(i)
    
31.             brr(r, 4) = Mid(dic(k), 1, Len(dic(k)) - 1)
    
32.         Next i
    
33.         r = r + 1
    
34.     Next k
    
35.     Sheet1.[s2].Resize(UBound(brr), 4) = brr
    
36. End Sub
    

复制代码

grf1973

参与一下。。。。

grf1973

jsa做了一下。。。。