用函数或VBA提取不及格学生名单！

pjiang

ylj518 发表于 2024-10-22 09:36
Sub test00()
Dim arr(), arr0()
Dim i&, k&

对头，，，，，，，，

lc16whj

pjiang 发表于 2024-10-22 15:42
对头，，，，，，，，

试了一下，提取的数据不完整。还是用函数，只是函数运行有一点点卡，不再折腾了，谢谢您的指导！

pjiang

lc16whj 发表于 2024-10-22 16:33
试了一下，提取的数据不完整。还是用函数，只是函数运行有一点点卡，不再折腾了，谢谢您的指导！

代码优化了一下，，，，，，

lc16whj

pjiang 发表于 2024-10-22 16:58
代码优化了一下，，，，，，

Sub test00()
Dim arr(), arr0()
Set dict = CreateObject("Scripting.Dictionary")
Dim subject As String
Dim pass As Integer



Set Sh1 = Sheets("成绩")
Set sh2 = Sheets("不及格名单")
row1 = Sh1.UsedRange.Rows.Count
col1 = Sh1.UsedRange.Columns.Count
row2 = sh2.UsedRange.Rows.Count


sh2.Range("A2:E" & row2).Clear



'重写数组
ReDim arr(1 To row1, 1 To col1 + 3) '
ReDim arr0(1 To row1 * 10, 1 To 5) '
With Sh1
Set Rng = .Range(.Cells(2, 1), .Cells(row1, col1))
End With
arr = Rng.Value
'判断

k = 1
For i = 1 To UBound(arr)
    For j = 1 To 10
            subject = Choose(j, "语文", "数学", "英语", "物理", "化学", "政治", "历史", "生物", "地理", "体育")
            pass = Choose(j, 72, 72, 72, 48, 42, 48, 48, 30, 30, 36)
            
            '语文
            If Int(arr(i, j + 3)) < pass Then
                arr0(k, 1) = arr(i, 1)
                arr0(k, 2) = arr(i, 2)
                arr0(k, 3) = arr(i, 3)
                arr0(k, 4) = subject
                arr0(k, 5) = arr(i, j + 3)
                k = k + 1
            End If
    Next

Next
   


'写入
For i = 1 To UBound(arr0)
        If Not IsEmpty(arr0(i, 1)) Then
                sh2.Cells(i + 1, 1) = arr0(i, 1)
                sh2.Cells(i + 1, 2) = arr0(i, 2)
                sh2.Cells(i + 1, 3) = arr0(i, 3)
                sh2.Cells(i + 1, 4) = arr0(i, 4)
                sh2.Cells(i + 1, 5) = arr0(i, 5)
        End If
Next
End Sub