根据分值段将两列姓名重排

cnmlgb9998

PQ 一步到位！！！！！！！！！！！

GUQLM

cnmlgb9998 发表于 2024-3-11 16:20
PQ 一步到位！！！！！！！！！！！

感谢cnmlgb9998 老师的指导。PQ完全不懂，我要学的东西太多了，希望能学到。

yynrzwh

Sub test()

Set d = New Dictionary
t = [{100,90,80,70,60,50}]
ar = Range("a1").CurrentRegion
ReDim br(1 To UBound(ar) * 2, 1 To UBound(t))
    For i = 2 To UBound(ar)
        For x = 1 To UBound(t)
            If ar(i, 3) >= t(x) / 100 Then
                d(x) = d(x) + 1
                br(d(x), x) = ar(i, 1)
                d(x) = d(x) + 1
                br(d(x), x) = ar(i, 2)
                Exit For
            End If
        Next
    Next
Range("e2").Resize(UBound(ar), UBound(br, 2)) = br

For j = 5 To UBound(t) + 4
    Columns(j).Sort Cells(2, j), Header:=xlYes
Next
End Sub

GUQLM

yynrzwh 发表于 2024-3-11 16:39
Sub test()

Set d = New Dictionary

yynrzwh，感谢老师的帮助。


我测试了程序，出现一个提示; 能麻烦老师看看吗？

yynrzwh

红色这句改一下
Sub test()

Set d = CreateObject("scripting.dictionary")
t = [{100,90,80,70,60,50}]
ar = Range("a1").CurrentRegion
ReDim br(1 To UBound(ar) * 2, 1 To UBound(t))
    For i = 2 To UBound(ar)
        For x = 1 To UBound(t)
            If ar(i, 3) >= t(x) / 100 Then
                d(x) = d(x) + 1
                br(d(x), x) = ar(i, 1)
                d(x) = d(x) + 1
                br(d(x), x) = ar(i, 2)
                Exit For
            End If
        Next
    Next
Range("e2").Resize(UBound(ar), UBound(br, 2)) = br

For j = 5 To UBound(t) + 4
    Columns(j).Sort Cells(2, j), Header:=xlYes
Next
End Sub

GUQLM

yynrzwh 发表于 2024-3-11 21:20
红色这句改一下
Sub test()

修改了程序可以运行了，谢谢老师的帮助。