[已解决]求助能否把缺考的成绩排名排序到最后的，谢谢

qinhuan66 · 发表于 2013-6-18 16:51

本帖最后由 qinhuan66 于 2013-6-18 16:59 编辑

求助能否把缺考的成绩排名排序到最后的，谢谢，现在缺考为第一名了。如何把他当0处理（但不能输入0）

303234-VBA-字典-中国式排名.rar (33.41 KB, 下载次数: 11)

qinhuan66 · 发表于 2013-6-18 19:06

{:1112:}顶一顶

qinhuan66 · 发表于 2013-6-18 20:36

我换成这样可以了，但有点别纽
Private Sub CommandButton1_Click()
Selection.Replace What:="缺考", Replacement:="0", LookAt:=xlWhole, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False
Range("J13").Select '把缺考转换成0
Dim Arr1, Arr12(), Arr13()

With Sheets("资料")
      row1 = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("h3:h" & row1).ClearContents
      Arr1 = .Range("B3:E" & row1)
      ReDim ARR11(1 To UBound(Arr1), 1 To 2)

      Set D1 = CreateObject("Scripting.Dictionary")
      Set D2 = CreateObject("Scripting.Dictionary")

      For i = 1 To UBound(Arr1)
         If Not D1.EXISTS(Arr1(i, 1)) Then
            m1 = m1 + 1
            D1(Arr1(i, 1)) = m1
            ReDim Preserve Arr12(1 To 2, 1 To m1)
            Arr12(1, m1) = Arr1(i, 1)
            Arr12(2, m1) = m1
         End If
         ARR11(i, 2) = Format(D1(Arr1(i, 1)), "00")
      Next i
      For j = 1 To m1
         For i = 1 To UBound(Arr1)
            If Arr12(1, j) = Arr1(i, 1) Then
                  If Not D2.EXISTS(Arr1(i, 4)) Then
                     M2 = M2 + 1
                     D2(Arr1(i, 4)) = M2
                     ReDim Preserve Arr13(1 To 2, 1 To M2)
                     Arr13(1, M2) = Arr1(i, 4)
                     Arr13(2, M2) = M2
                     If M2 > 1 Then
                        For k1 = 1 To M2 - 1
                              For k2 = k1 + 1 To M2
                                 If Arr13(1, k1) < Arr13(1, k2) Then
                                    t = Arr13(1, k1)
                                    Arr13(1, k1) = Arr13(1, k2)
                                    Arr13(1, k2) = t
                                 End If
                              Next k2
                        Next k1
                     End If
                  End If
            End If
         Next i
         For i = 1 To UBound(Arr1)
            If Arr12(1, j) = Arr1(i, 1) Then
                  For K3 = 1 To M2
                     If Arr13(1, K3) = Arr1(i, 4) Then
                        ARR11(i, 1) = Arr13(2, K3)
                        Exit For
                     End If
                  Next K3
            End If
         Next i
         Erase Arr13
         D2.RemoveAll
         M2 = 0
      Next j
      .Range("F3").Resize(UBound(ARR11), 1) = ARR11
End With
Columns("E:E").Select
Selection.Replace What:="0", Replacement:="缺考", LookAt:=xlWhole, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False '把0转换成缺考
End Sub

那么的帅 · 发表于 2013-6-19 09:17

303252-VBA-字典-中国式排名.rar (33.63 KB, 下载次数: 10)

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

[已解决]求助能否把缺考的成绩排名排序到最后的，谢谢

评分