- Sub test()
- Dim arr, x As Integer, brr(1 To 10000, 1 To 5), z, zf, k, r
- Set z = CreateObject("scripting.dictionary")
- arr = Range("a1").CurrentRegion
- For x = 1 To UBound(arr)
- zf = arr(x, 3) & arr(x, 4) & arr(x, 5) & arr(x, 6)
- If z.exists(zf) Then
- r = z(zf): brr(r, 5) = brr(r, 5) + 1
- Else
- k = k + 1
- z(zf) = k
- brr(k, 1) = arr(x, 3)
- brr(k, 2) = arr(x, 4)
- brr(k, 3) = arr(x, 5)
- brr(k, 4) = arr(x, 6)
- brr(k, 5) = 1
- End If
- Next
- Sheets("结果示例").Select
- [a:e].Clear
- [a1].Resize(k, 5) = brr: [e1] = ""
- MsgBox "统计完毕"
- End Sub
复制代码 |