VBA关于统计结果的显示问题？

dzzxlbj

求助：现需要统计一个年级的各班级的及格人员名单，并以班级为单位横向显示，现在我写的代码如下，运行后所得到的结果虽然横向显示，但不是以班级为单位，而且是累计的，请老师给指点下我哪里写错了？如何能实现我所说的效果。 测试.rar (22.14 KB, 下载次数: 7)

2020-1-23 11:34 上传

点击文件名下载附件

Sub test()
Dim arr, k%, i%, n%, m%, brr(1 To 500, 1 To 3)
arr = Sheet1.Range("a1").CurrentRegion
k = UBound(arr, 1) - 1
For m = 1 To 10
For i = 2 To k
If arr(i, 1) = "七" & m & "班" And arr(i, 3) >= 60 Then
n = n + 1
brr(n, 1) = arr(i, 1)
brr(n, 2) = arr(i, 2)
brr(n, 3) = arr(i, 3)
End If
Next i
Sheet2.Cells(2, Sheet2.Range("fd2").End(xlToLeft).Column + 1).Resize(n, 3) = brr
Next m
End Sub
想实现的效果

现在的效果

鄂龙蒙

1. Sub test()
   
2.     Dim arr, j%, i%, n%, m%, brr(1 To 500, 1 To 3)
   
3.     arr = Sheet1.Range("a1").CurrentRegion
   
4.     For m = 1 To 10
   
5.         For i = 2 To UBound(arr, 1) - 1
   
6.             If arr(i, 1) = "七" & m & "班" And arr(i, 3) >= 60 Then
   
7.                 n = n + 1
   
8.                 For j = 1 To 3
   
9.                     brr(n, j) = arr(i, j)
   
10.                 Next
    
11.             End If
    
12.         Next i
    
13.         Sheet2.Cells(2, Sheet2.Range("fd2").End(xlToLeft).Column + 1).Resize(n, 3) = brr
    
14.         Erase brr
    
15.         n = 0
    
16.     Next m
    
17. End Sub

复制代码

microyip

用字典记录一下就可以了

3190496160

这样似乎更灵活通用，不受班级名称和班级数的限制，
Sub test()
Set d = CreateObject("scripting.dictionary")
ar = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(Trim(ar(i, 1))) = ""
    End If
Next i
x = d.keys
For i = 0 To UBound(x)
    For s = i + 1 To UBound(x)
        If x(i) > x(s) Then
            k = x(i)
            x(i) = x(s)
            x(s) = k
        End If
    Next s
Next i
Sheet2.UsedRange = Empty
y = 1
For s = 0 To UBound(x)
    n = 0
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) = x(s) And ar(i, 3) >= 60 Then
            n = n + 1
            For j = 1 To UBound(ar, 2)
                br(n, j) = ar(i, j)
            Next j
        End If
    Next i
    Sheet1.Range("a1:c1").Copy Sheet2.Cells(1, y)
    Sheet2.Cells(2, y).Resize(n, UBound(br, 2)) = br
    y = y + UBound(br, 2)
Next s
End Sub

3190496160

测试.zip (27.01 KB, 下载次数: 3)

2020-1-23 12:24 上传

点击文件名下载附件

dzzxlbj

鄂龙蒙 发表于 2020-1-23 11:54

谢谢  明白了

dzzxlbj

microyip 发表于 2020-1-23 11:37
用字典记录一下就可以了

谢谢  还没有接触字典

dzzxlbj

鄂龙蒙 发表于 2020-1-23 11:54

如果用redim 应该怎么改？

cui26896

Sub test()
Dim arr, k%, i%, n%, m%, brr

arr = Sheet1.Range("a1").CurrentRegion
k = UBound(arr, 1) - 1
For m = 1 To 10
ReDim brr(1 To UBound(arr, 1) - 1, 1 To 3)
For i = 2 To k
If arr(i, 1) = "七" & m & "班" And arr(i, 3) >= 60 Then
n = n + 1
brr(n, 1) = arr(i, 1)
brr(n, 2) = arr(i, 2)
brr(n, 3) = arr(i, 3)
End If
Next i
Sheets(2).Cells(2, Columns.Count).End(xlToLeft).Offset(0, 1).Resize(n, 3) = brr
n = 0
Next m
End Sub

dzzxlbj

cui26896 发表于 2020-1-23 13:08
Sub test()
Dim arr, k%, i%, n%, m%, brr

非常感谢