【原】VBA代码和公式一样有套路。真心感觉，套路掌握越多，耍EXCEL时能少走好多弯路！

欢迎转发和点一下“在看”，文末留言互动!

置顶公众号或设为星标及时接收更新不迷路

小伙伴们好，今天向大家分享的是一篇过往推文。上一次这篇推文使用公式解答的，而今天将会向大家介绍一段VBA代码。

关于公式的详细解答请参看帖子SUMIF函数也可以这样用！这真出乎意料，赶紧来围观吧！

下面这段代码是仿写小白大佬的，主要是学习他的解题思路和字典应用的技巧。

原题是这样的：

如何妙用字典来解决这道问题呢？

01

完整代码如下：

Sub 录取()    Dim myarr As Variant, mybrr As Variant, mydic As Object, res As Variant, i, m, n    myarr = Sheet1.Range("A1").CurrentRegion    mybrr = Sheet1.Range("M2:N6")    Set mydic = CreateObject("scripting.dictionary")    For i = 1 To UBound(mybrr)        mydic(mybrr(i, 1)) = mybrr(i, 2)        mydic(mybrr(i, 1) & "-c") = i    Next i    ReDim res(1 To 100, 1 To UBound(mybrr))    For m = 2 To UBound(myarr)        For n = 3 To UBound(myarr, 2)            If myarr(m, 2) > mydic(myarr(m, n)) Then                mydic(myarr(m, n) & "-r") = mydic(myarr(m, n) & "-r") + 1                res(mydic(myarr(m, n) & "-r"), mydic(myarr(m, n) & "-c")) = myarr(m, 1)                Exit For            End If        Next n    Next m    [g3].Resize(UBound(res), UBound(mybrr)) = resEnd Sub

Set mydic = CreateObject("scripting.dictionary")For i = 1 To UBound(mybrr)    mydic(mybrr(i, 1)) = mybrr(i, 2)    mydic(mybrr(i, 1) & "-c") = iNext i

第5-9行代码：创建字典，将校名和分数先装入字典。同时，另创建一个字典，校名和“-c”所结合的字符串作为键，校名在"M2:N6"这个区域中所在行的行数作为键值。

这个的目的是控制列，将那些总成绩超过志愿学校的名字精准地放在对应学校的同一列。观察一下源数据，我们可以发现最终结果中学校的排序和"M2:N6"区域中学校的排序是一致的。

ReDim res(1 To 100, 1 To UBound(mybrr))

第10行代码，重新定义动态数组res

For m = 2 To UBound(myarr)    For n = 3 To UBound(myarr, 2)        If myarr(m, 2) > mydic(myarr(m, n)) Then            mydic(myarr(m, n) & "-r") = mydic(myarr(m, n) & "-r") + 1            res(mydic(myarr(m, n) & "-r"), mydic(myarr(m, n) & "-c")) = myarr(m, 1)            Exit For        End If    Next nNext m

第11-19行代码，2层循环，对动态数组res赋值。当总成绩myarr(m, 2)大于学校的成绩mydic(myarr(m, n))时（myarr(m, n)控制的是学校名，mydic(myarr(m, n))的键值就是对应学校的分数线），mydic(myarr(m, n) & "-r")实现自动累加。

这个控制了每个学校下面人名清单的行数。通过“-c”和“-r”这两个小操作，被录取的学生姓名可以分门别类地自动放置在对应学校的下方。

[g3].Resize(UBound(res), UBound(mybrr)) = res

第20行代码：数据输出

-END-