[已解决]请给予帮忙,由数据表得到排名表,谢谢!

yabifdp

 

请教老师:
  如何做一个宏,直接由原始数据表得到本排名表,谢谢!
我用录制宏做过,但每次人数不同A列就必须手工完成,故请高手帮忙
做一个完全自动的,
且有相同分时名次相同,如第4\5名分数相同,名次应该是4\4,附件中的名次应该是1.2.3.4.4.6.7.7.9…….谢谢!

m87wqBh4.rar (32.2 KB, 下载次数: 10)

2009-11-15 21:33 上传

点击文件名下载附件
请给予帮忙,由数据表得到排名表,谢谢!

最佳答案

月排行榜 / 总排行榜

knifefox

2009-11-16 00:02

Sub test()
    Dim i As Long
    Dim j As Long
    Dim n As Integer
    Dim Lrow As Long
    Dim Arr1, Arr2(), temp
    With Sheets("原始数据")
        Lrow = .[A65536].End(xlUp).Row
        Arr1 = .Range("A1:D" & Lrow)
    End With
    For i = 2 To Lrow
        For j = 2 To Lrow
            If Arr1(i, 4) > Arr1(j, 4) Then
                temp = Application.Index(Arr1, i)
                For n = 1 To 4
                    Arr1(i, n) = Arr1(j, n)
                    Arr1(j, n) = temp(n)
                Next
            End If
        Next
    Next
    ReDim Arr2(1 To Lrow)
    Arr2(1) = "名次"
    For i = 2 To Lrow
        If Arr1(i, 4) = Arr1(i - 1, 4) Then
            Arr2(i) = Arr2(i - 1)
        Else
            Arr2(i) = i - 1
        End If
    Next
    With Sheets("排名表")
        .Cells.Delete
        .[A1].Resize(Lrow, 1) = Application.Transpose(Arr2)
        .[B1].Resize(Lrow, 4) = Arr1
        .[A1].Resize(Lrow, 5).Borders.LineStyle = xlContinuous
    End With
End Sub

跳转到最佳答案楼层

雨狐

试一个，不知道行不行

 

JpLgexKJ.rar (43.87 KB, 下载次数: 1)

2009-11-15 23:37 上传

点击文件名下载附件

[此贴子已经被作者于2009-11-15 23:36:35编辑过]

yabifdp

谢谢你,但不符合我的要求啊,
我的前10名依次是1.2.3.4.4.6.7.7.9…….
你的前10名依次是1.2.3.4.4.5.6.6.7.....

knifefox

Sub test()
    Dim i As Long
    Dim j As Long
    Dim n As Integer
    Dim Lrow As Long
    Dim Arr1, Arr2(), temp
    With Sheets("原始数据")
        Lrow = .[A65536].End(xlUp).Row
        Arr1 = .Range("A1:D" & Lrow)
    End With
    For i = 2 To Lrow
        For j = 2 To Lrow
            If Arr1(i, 4) > Arr1(j, 4) Then
                temp = Application.Index(Arr1, i)
                For n = 1 To 4
                    Arr1(i, n) = Arr1(j, n)
                    Arr1(j, n) = temp(n)
                Next
            End If
        Next
    Next
    ReDim Arr2(1 To Lrow)
    Arr2(1) = "名次"
    For i = 2 To Lrow
        If Arr1(i, 4) = Arr1(i - 1, 4) Then
            Arr2(i) = Arr2(i - 1)
        Else
            Arr2(i) = i - 1
        End If
    Next
    With Sheets("排名表")
        .Cells.Delete
        .[A1].Resize(Lrow, 1) = Application.Transpose(Arr2)
        .[B1].Resize(Lrow, 4) = Arr1
        .[A1].Resize(Lrow, 5).Borders.LineStyle = xlContinuous
    End With
End Sub

yabifdp

人事部长出手，谢谢！

东方智彩

谢谢学习了!

qrst205

奇迹 新开奇迹私服超级变态奇迹私服最新奇迹私服