|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Sub qs()
- Dim arr, i, dic
- Set dic = CreateObject("scripting.dictionary")
- Set d2 = CreateObject("scripting.dictionary")
- ar = [{"政史地",135,440;"政史生",25,72;"物化地",17,67;"物化生",104,213}]
- For i = 1 To UBound(ar)
- d2(ar(i, 1)) = Array(ar(i, 2), ar(i, 3))
- Next
- With Sheet1
- arr = .Range("a1").CurrentRegion.Value
- ReDim brr(1 To UBound(arr), 1 To 4)
- For i = 2 To UBound(arr)
- s = arr(i, 1) & arr(i, 3)
- If Not dic.exists(s) Then
- If d2.exists(arr(i, 3)) Then
- m = m + 1
- dic(s) = m
- brr(m, 1) = arr(i, 1): brr(m, 4) = arr(i, 3)
- ms = d2(arr(i, 3))
- brr(m, 3) = IIf(arr(i, 2) <= ms(0), 1, 0)
- brr(m, 2) = IIf(arr(i, 2) > ms(0) And arr(i, 2) <= ms(1), 1, 0)
- End If
- Else
- If d2.exists(arr(i, 3)) Then
- ms = d2(arr(i, 3))
- rw = dic(s)
- brr(rw, 3) = brr(rw, 3) + IIf(arr(i, 2) <= ms(0), 1, 0)
- brr(rw, 2) = brr(rw, 2) + IIf(arr(i, 2) > ms(0) And arr(i, 2) <= ms(1), 1, 0)
- End If
- End If
- Next
- .Range("f2").Resize(10000, 4) = Empty
- .Range("f2").Resize(m, 4) = brr
- End With
- Set dic = Nothing: Set d2 = Nothing
- End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-10-10 08:59
