求助：用VBA提取数据并进行排名

wuchengde

longkkkk 发表于 2019-4-20 01:55
我也是新手，刚刚学习VBA，可能写得比较啰嗦，你看看可不可以用

代码是没有那些高手写的简洁，测试了，但能达到想要的效果，我也基本能看得懂。但写入数据采用单个单个的写入，数据多后可能会很慢。有了你的思路和方法，我再改为写入数组，再用数组写入到表格中，可能速度会快一点。

有两个地方不太明白，请你帮解释一下：
第一问：Range("W" & i).Value = Application.WorksheetFunction.Rank(Range("V" & i).Value, Range("V" & uprow(Range("C" & i)) & ":V" & downrow(Range("C" & i))), 0)  中的 Range("V" & uprow(Range("C" & i)) & ":V" & downrow(Range("C" & i)) 指的是区域，但我没太明白。
第二问：就是你自定义的那两个功能
Function uprow(ByVal aaa As Range)
    Dim h, l, i&
    h = aaa.Row
    l = aaa.Column
    For i = aaa.Row To 1 Step -1
        If aaa.Value <> Cells(i, l).Value Then Exit For
    Next
    uprow = i + 1
End Function

Function downrow(ByVal aaa As Range)
    Dim h, l, i&
    h = aaa.Row
    l = aaa.Column
    For i = aaa.Row To Rows.Count
        If aaa.Value <> Cells(i, l).Value Then Exit For
    Next
    downrow = i - 1
End Function

能注释一下吗？没明白是什么意思。

longkkkk

其实就是工作表的rank函数，uprow和downrow就是用来确定rank的区域的

wuchengde

longkkkk 发表于 2019-4-20 22:27
其实就是工作表的rank函数，uprow和downrow就是用来确定rank的区域的

一看就知道是rank函数，我只是没看明白uprow和downrow是怎么个回事，简单描述一下可行？

乐乐2006201505

建立个mb(1-2)工作表，把其它三科删除。设计好表格即可。无法上传附件。
Sub 排名()
Dim s As String, ss As String, arr, brr, vs, i%, j%, i1%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheets("基本信息设置")
  s = "成绩总表(" & .Range("d2") & ")"
  ss = .Range("d2")
End With
With Sheets("原始成绩")
  arr = .[a1].CurrentRegion
End With
  If IsSheetExist(s) Then Sheets(s).Delete
  Sheets("mb(1-2)").Copy before:=Sheets(2)
  ActiveSheet.Name = s
  vs = Array(1, 2, 3, 4, 5, 6, 10, 14, 18, 22, 26)
  ReDim brr(1 To UBound(arr), 1 To 29)
With Sheets(s)
  For i = 4 To UBound(arr)
    If arr(i, 3) = Left(ss, 1) Then
      i1 = i1 + 1
      For j = 3 To 10
        brr(i1, vs(0)) = arr(i, 2)
        brr(i1, vs(j - 2)) = arr(i, j)
        brr(i1, vs(9)) = arr(i, 14)
        brr(i1, vs(10)) = arr(i, 15)
      Next j
    End If
  Next i
  .Range("a5").Resize(UBound(brr), 29) = brr
  r = .Cells(.Rows.Count, 1).End(3).Row
  .Rows("5:5").Select
  Selection.Copy
  .Rows("6:" & r).Select
  Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
  Application.CutCopyMode = False
  .Range("a5").Select
End With
For c1 = 6 To 29 Step 4
  Call zpm(c1, c1 + 3, 4) '第一个参数为排名列号，第二个参数为排名列，第三参数为标题行数
  Call xpm(c1, c1 + 2, 4)
  Call bpm(c1, c1 + 1, 4)
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "本次成绩统计已完成！" & Chr(13) & Chr(13) & "总运行时间为：" & Timer - tim & " 秒！"
End Sub

Function IsSheetExist(SheetName) As Boolean '判断是否存在某工作表
On Error GoTo eee
Dim a: a = Sheets(SheetName).Name
IsSheetExist = True
eee:
End Function

Sub zpm(c1, c2, br) '总排名
  Dim arr1, brr1, x&, y&, i&, r&
  r = Cells(Rows.Count, c1).End(3).Row '这就是取得l列最后一行的行号
  arr1 = Range(Cells(br + 1, c1), Cells(r, c1))
  ReDim brr1(1 To UBound(arr1), 1 To 1)
  For x = 1 To UBound(arr1)
    i = UBound(arr1)
    For y = 1 To UBound(arr1)
      If arr1(x, 1) >= arr1(y, 1) And x <> y Then i = i - 1
    Next y
    Cells(x + br, c2) = i
  Next x
End Sub

Sub xpm(c1, c2, br) '校排名
  Dim arr1, brr1, x&, y&, i&, r&
  r = Application.CountIf(Range(Cells(br + 1, 1), Cells(Cells(Rows.Count, 1).End(3).Row, c1)), "学校1")
  r1 = Cells(Rows.Count, c1).End(3).Row '这就是取得l列最后一行的行号
  arr1 = Range(Cells(br + 1, c1), Cells(r + br, c1))
  ReDim brr1(1 To UBound(arr1), 1 To 1)
  For x = 1 To UBound(arr1)
    i = UBound(arr1)
    For y = 1 To UBound(arr1)
      If arr1(x, 1) >= arr1(y, 1) And x <> y Then i = i - 1
    Next y
    Cells(x + br, c2) = i
  Next x
  arr2 = Range(Cells(r + br + 1, c1), Cells(r1, c1))
  ReDim brr2(1 To UBound(arr2), 1 To 1)
  For x1 = 1 To r1 - r - br
    i = UBound(arr2)
    For y1 = 1 To UBound(arr2)
      If arr2(x1, 1) >= arr2(y1, 1) And x1 <> y1 Then i = i - 1
    Next y1
    Cells(x1 + r + br, c2) = i
  Next x1
End Sub

Sub bpm(c1, c2, br) '班排名
  Dim arr1, brr1, x&, y&, i&, r&, vs()
  On Error Resume Next
  r1 = Cells(Rows.Count, c1).End(3).Row '这就是取得l列最后一行的行号
  For i2 = 1 To r1
    arr2 = Range(Cells(br, 3), Cells(r1 + br, 3))
    If arr2(i2, 1) <> arr2(i2 + 1, 1) Then
      c = c + 2
      ReDim Preserve vs(1 To c)
      vs(c - 1) = i2 + br - 1: vs(c) = i2 + br
    End If
  Next i2
  For i3 = 2 To UBound(vs) - 2 Step 2
    arr1 = Range(Cells(vs(i3), c1), Cells(vs(i3 + 1), c1))
    ReDim brr1(1 To UBound(arr1), 1 To 1)
    For x = 1 To UBound(arr1)
      i = UBound(arr1)
      For y = 1 To UBound(arr1)
        If arr1(x, 1) >= arr1(y, 1) And x <> y Then i = i - 1
      Next y
      Cells(x + vs(i3) - 1, c2) = i
    Next x
  Next i3
End Sub

longkkkk

wuchengde 发表于 2019-4-20 23:29
一看就知道是rank函数，我只是没看明白uprow和downrow是怎么个回事，简单描述一下可行？

uprow（a）就是向上找与单元格a的内容相同的行号最小的单元格，并返回它的行值，我就是为了找同一个学校或者是同一个班，确定rank的区域

不知道为什么

凑个热闹，练练手。

wuchengde

longkkkk 发表于 2019-4-21 00:23
uprow（a）就是向上找与单元格a的内容相同的行号最小的单元格，并返回它的行值，我就是为了找同一个学校 ...

谢谢，明白了。

wuchengde

mjzxlmg 发表于 2019-4-20 21:40

好像不对哦，连获取过来的基础分数值都对不上哦

wuchengde

不知道为什么 发表于 2019-4-21 12:18
凑个热闹，练练手。

好，快速。可以的话，麻烦上传代码，大家学习学习！

wuchengde

乐乐2006201505 发表于 2019-4-20 23:39
建立个mb(1-2)工作表，把其它三科删除。设计好表格即可。无法上传附件。
Sub 排名()
Dim s As String, ss ...

一、二年级是可以了，但三-六年级没考虑统计英语、科学、品德