|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
'有多个等级数超过10,debug窗口中有提示,,,
Option Explicit
Sub test()
Dim arr, i, j, t, s, dic, m, n, key
Set dic = CreateObject("scripting.dictionary")
arr = Sheets("数据表").[a1].CurrentRegion
For i = 2 To UBound(arr, 1)
If dic.exists(arr(i, 1)) Then
t = dic(arr(i, 1))
ReDim Preserve t(UBound(t) + 2)
t(UBound(t) - 1) = arr(i, 2): t(UBound(t)) = arr(i, 3)
dic(arr(i, 1)) = t
Else
ReDim t(1)
t(0) = arr(i, 2): t(1) = arr(i, 3): dic(arr(i, 1)) = t
End If
Next
ReDim arr(1 To UBound(arr, 1), 1 To 10 + 4) As String
For Each key In dic.keys
m = m + 1: n = 1
t = dic(key)
For i = 1 To UBound(t) - 2
For j = i + 2 To UBound(t) Step 2
If t(i) > t(j) Then
s = t(i): t(i) = t(j): t(j) = s
s = t(i - 1): t(i - 1) = t(j - 1): t(j - 1) = s
End If
Next j, i
arr(m, 1) = key: arr(m, 12) = t(UBound(t) - 1)
arr(m, 13) = t(1): arr(m, 14) = t(UBound(t))
For i = 1 To UBound(t) Step 2
n = n + 1
If n = 12 Then Debug.Print "行:" & m + 1, key, "等级数量超过10!": Exit For
arr(m, n) = t(i - 1)
Next i, key
With Sheets("汇总表").[a2]
.Resize(Rows.Count - 1, UBound(arr, 2)).ClearContents
.Resize(m, UBound(arr, 2)) = arr
End With
End Sub |
评分
-
2
查看全部评分
-
|