赋值ABCD-求助修改

熊文来

感谢 走过录入的大师们，帮忙看看 谢谢！


原文件中已经有一段代码 是模拟数据时，别人帮忙写的代码，只是一个科目，实际中是所有科目在一起，所以麻烦在工作表2中 利用工作表1个代码 完成工作表工作表2中所有科目的等级录入。


谢谢大家了！

microyip

想确保无误，找有偿服务，一般都有售后，所以问题不大的

liulang0808

Sub test()
    Set d = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    brr = Array(20, 30, 30)
    Dim drr(0 To 2)
    arr = Sheets("一科赋等级").UsedRange
    For j = 2 To UBound(arr)
        d(arr(j, 1)) = d(arr(j, 1)) & "*" & arr(j, 5)
    Next j
    For Each k In d.keys
        crr = Split(d(k), "*")
        For j = 1 To UBound(crr)
            For i = j + 1 To UBound(crr)
                If Val(crr(i)) > Val(crr(j)) Then
                    tm = Val(crr(j))
                    crr(j) = Val(crr(i))
                    crr(i) = tm
                End If
            Next i
        Next j
        s = 0
        For i = 0 To UBound(brr)
            x = UBound(crr) * brr(i) / 100 + s
            For j = x + 1 To UBound(crr)
                If crr(x) <> crr(j) Then
                    s = j
                    drr(i) = Val(crr(x))
                    Exit For
                End If
            Next j
        Next i
        d(k) = drr
    Next k
    For j = 2 To UBound(arr)
        brr = d(arr(j, 1))
        arr(j, 8) = "D"
        For i = 0 To 2
            If arr(j, 5) >= Val(brr(i)) Then
                arr(j, 8) = Mid("ABC", i + 1, 1)
                Exit For
            End If
        Next i
    Next j
    Sheets("一科赋等级").UsedRange = arr
End Sub

liulang0808

附件内容供参考
感觉之前答复过雷同的需求。。。。。

熊文来

liulang0808 发表于 2022-5-9 07:58
附件内容供参考
感觉之前答复过雷同的需求。。。。。

大师，看了你的结果 这样有3个不同的做法，结果3个结果都有地方不相同。我验证了下还是我发的文件里面的第二种做法是正确的。你能不能帮我把第二张表的九科赋值弄一下呢？》谢谢

779846526

microyip 发表于 2022-5-8 23:14
想确保无误，找有偿服务，一般都有售后，所以问题不大的

哈哈，论坛里向钱看的人要向版主学习哈，业务没了，这个如果没人回，估计又要漫天要价了吧

准提部林

A級人數=188, B級人數=282,  C級人數=282
那若A級最低同份有多人, 而取出190人,
那B級還是要取282人???
又..B級最低分也有多人, C級也同樣要取足282人???
到最後剩下的歸D級???

亦即, 以上一級的最低分為界, 取得應有人數或者更多?

附件中代碼若是正確的, 可用表一當輔助, 將各科目分數逐一複製過去,
執行後, 再將結果貼回相對應科目分級列即可~~

feilanga

779846526 发表于 2022-5-9 09:56
哈哈，论坛里向钱看的人要向版主学习哈，业务没了，这个如果没人回，估计又要漫天要价了吧

向钱看无可厚非，别人可以写出满足你需求的代码，也是付出大量时间和精力甚至金钱成本去学习后的结果。有人愿意免费帮忙，获取解答问题的乐趣。有人只愿获取金钱的回报。都有什么错呢？付出都会有成本的，凭什么就只想着让别人免费帮你呢，帮你是自愿，不帮也是理所当然。没有必要上纲上线。

microyip

779846526 发表于 2022-5-9 09:56
哈哈，论坛里向钱看的人要向版主学习哈，业务没了，这个如果没人回，估计又要漫天要价了吧

对的，要像版主那样，隐晦一点，不要明显

liulang0808

增加了向上取整，如果还有出入，