Question

VB Excel问题代码需要修改，求指正

Option ExplicitSub 排名()Dim dic As New DictionaryDim i As Integer, j As Integer, k As Integer, m As Integer, n As IntegerDim arrDim rng As RangeColumns("d:j").Clearn = Cells(Rows.Count, 1).End(xlUp).Rowarr = Range("a1").CurrentRegionFor i = 2 To UBound(arr) dic.Item(arr(i, 2)) = ""NextFor j = 0 To dic.Count - 1 k = k + 1 For Each rng In Range("b2:b" & n) If rng.Value = dic.Keys(j) Then m = m + 1 Cells(k, 4) = "第" & k & "名" Cells(k, m + 4) = rng.Offset(0, -1).Value End If Next m = 0NextEnd Sub





Answer 1

现在的代码缺少排名过程，正确的程序代码如下图：

执行效果：

代码文本：

Option Explicit

Sub 排名()

    Dim arr, rlt, dic, i, j, t, t2

    arr = Range("a1").CurrentRegion

    Set dic = CreateObject("Scripting.Dictionary")

    For i = 2 To UBound(arr)

        dic(arr(i, 2)) = 0

    Next i

    ReDim rlt(1 To dic.Count, 1 To UBound(arr))

    For Each t In dic.Keys

        For Each t2 In dic.Keys

            If t2 >= t Then dic(t) = dic(t) + 1

        Next t2

        '此时dic(t)为成绩t的名次

        j = 2 '输出数组的列

        For i = 2 To UBound(arr)

            If arr(i, 2) = t Then

                rlt(dic(t), j) = arr(i, 1)

                j = j + 1

            End If

        Next i

    Next t

    For i = 1 To UBound(rlt)

        rlt(i, 1) = "第" & i & "名"

    Next i

    Range("d1").Resize(UBound(rlt), UBound(rlt, 2)) = rlt '输出结果

End Sub

Answer 2

字典内先排序啊
去搜索一下：vba 字典排序

Answer 3

代码本身就没有排序功能。只是按出现的顺序出来。