|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
练练字典嵌套。
- Sub test()
- Dim r%, i%
- Dim arr, brr, crr()
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("cj")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a1:o" & r)
- End With
- For i = 2 To UBound(arr)
- If Not d.exists(arr(i, 4)) Then
- ReDim brr(1 To 5)
- brr(1) = arr(i, 4)
- ReDim crr(1 To 1)
- crr(1) = i
- Else
- brr = d(arr(i, 4))
- crr = brr(3)
- If arr(i, 14) > arr(crr(1), 14) Then
- ReDim Preserve crr(1 To 1)
- crr(1) = i
- ElseIf arr(i, 14) = arr(crr(1), 14) Then
- m = UBound(crr) + 1
- ReDim Preserve crr(1 To m)
- crr(m) = i
- End If
- End If
- brr(2) = brr(2) + 1
- For j = 5 To 13
- If arr(i, j) < IIf(j <= 7, 72, 60) Then
- Exit For
- End If
- Next
- If j > 13 Then
- brr(5) = brr(5) + 1
- End If
- brr(3) = crr
- d(arr(i, 4)) = brr
- Next
- With Worksheets("cj")
- m = 1
- For Each aa In d.keys
- m = m + 1
- brr = d(aa)
- crr = brr(3)
- brr(3) = arr(crr(1), 14)
- For j = 1 To UBound(crr)
- brr(4) = brr(4) & vbLf & arr(crr(j), 2)
- Next
- brr(4) = Mid(brr(4), 2)
- .Cells(m, 21).Resize(1, UBound(brr)) = brr
- Next
- End With
- End Sub
复制代码 |
|