求一段VBA，将与朱倩同学各科成绩差符合要求的学生找出并填入结果显示区内

zhengsong347 · 发表于 2023-5-7 14:42

本帖最后由 zhengsong347 于 2023-5-8 14:33 编辑

用VBA：将与朱倩同学各科成绩差符合要求的学生找出并填入结果显示区内

鄂龙蒙 · 发表于 2023-5-7 16:05

楼主设定的条件：是各科及总分的相差是全部符合？还是单个符合？结果不一样的呀！

zhengsong347 · 发表于 2023-5-7 17:30

本帖最后由 zhengsong347 于 2023-5-7 18:03 编辑

鄂龙蒙发表于 2023-5-7 16:05
楼主设定的条件：是各科及总分的相差是全部符合？还是单个符合？结果不一样的呀！

要求各科全部符合，，，，至少总分符合

chxw68 · 发表于 2023-5-9 15:34

Sub test()
Dim r%, i%
Dim arr, brr
With Worksheets("初一分班原始成绩")
tj = .Range("f2:o4")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a7:j" & r)
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
m = 0
For i = 1 To UBound(arr)
If arr(i, 4) <> tj(1, 4) Then
For j = 6 To UBound(arr, 2)
If Abs(arr(i, j) - tj(1, j)) > tj(3, j) Then
Exit For
End If
Next
If j > UBound(arr, 2) Then
m = m + 1
For j = 1 To UBound(arr, 2)
brr(m, j) = arr(i, j)
Next
End If
End If
Next
If m = 0 Then
MsgBox "没有符合条件数据！"
Exit Sub
End If
.Range("r4:aa" & .Rows.Count).ClearContents
.Range("r4").Resize(m, UBound(brr, 2)) = brr
MsgBox "共查到" & m & "条符合条件数据！"
End With
End Sub

复制代码

chxw68 · 发表于 2023-5-9 15:35

详见附件。

leeson7502 · 发表于 2023-5-17 14:50

不是太明白楼主的需求，按照给定的条件，好象没有符合条件的记录，于是我就在下面模拟了几条记录，不知是不是能达成楼主的目的。

Sub Query()
Dim arrDetail()
Dim arrA(), arrB(), arrC()
Dim iRow As Integer
Dim iName As String
Dim CompareType As String '1=正差，2=负差，3=正负差，4=总差
Dim strPrompt As String
strPrompt = "1=正差，2=负差，3=正负差，4=总差"
CompareType = InputBox(strPrompt, "请输入查询类型", 4)
If CompareType = "" Then Exit Sub
If InStr("/1/2/3/4/", CompareType) = 0 Then
MsgBox ("输入错误!")
Exit Sub
End If
m = 0
Sheet1.Activate
With ActiveSheet
iRow = .UsedRange.Rows.Count
.Range("R4:AA" & iRow).ClearContents
iName = .Range("I2")
arrDetail = .Range("A7:J" & iRow).Value
arrA = .Range("K2:O2").Value
arrB = .Range("K4:O4").Value
Select Case CompareType
Case Is = "1"
For i = 1 To UBound(arrDetail, 1)
For j = 1 To 4
If Round(arrA(1, j) - arrDetail(i, j + 5), 2) <> Round(arrB(1, j), 2) Then
Exit For
End If
If j = 4 Then
For p = 1 To 10
.Cells(4 + m, 17 + p) = arrDetail(i, p)
Next
m = m + 1
End If
Next
Next
Case Is = "2"
For i = 1 To UBound(arrDetail, 1)
For j = 1 To 4
If Round(arrDetail(i, j + 5) - arrA(1, j), 2) <> Round(arrB(1, j), 2) Then
Exit For
End If
If j = 4 Then
For p = 1 To 10
.Cells(4 + m, 17 + p) = arrDetail(i, p)
Next
m = m + 1
End If
Next
Next
Case Is = "3"
For i = 1 To UBound(arrDetail, 1)
For j = 1 To 4
If Abs(Round(arrA(1, j) - arrDetail(i, j + 5), 2)) <> Round(arrB(1, j), 2) Then
Exit For
End If
If j = 4 Then
For p = 1 To 10
.Cells(4 + m, 17 + p) = arrDetail(i, p)
Next
m = m + 1
End If
Next
Next
Case Is = "4"
For i = 1 To UBound(arrDetail, 1)
If Round(Abs(arrA(1, 5) - arrDetail(i, 10)), 2) = Round(arrB(1, 5), 2) Then
For p = 1 To 10
.Cells(4 + m, 17 + p) = arrDetail(i, p)
Next
m = m + 1
End If
Next
End Select
End With
End Sub

复制代码

		自动登录	找回密码
密码			免费注册