- Sub test()
- Columns("H:N").ClearContents
- Set dic = CreateObject("scripting.dictionary")
- lr = [B65536].End(xlUp).Row
- arr = Range("B3:G" & lr)
- ReDim brr(1 To UBound(arr, 1), 1 To 7)
- ReDim crr(1 To UBound(arr, 1), 1 To 7)
- For i = 1 To UBound(arr, 1)
- ss = arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)
- If Not dic.exists(ss) Then
- n = n + 1
- dic.Add ss, n
- brr(n, 1) = arr(i, 1): brr(n, 2) = arr(i, 2): brr(n, 3) = arr(i, 3): brr(n, 4) = arr(i, 4): brr(n, 5) = arr(i, 5): brr(n, 6) = arr(i, 6): brr(n, 7) = brr(n, 7) + 1
- Else
- brr(dic(ss), 7) = brr(dic(ss), 7) + 1
- End If
- Next
- n = 0
- For i = 1 To UBound(brr, 1)
- If brr(i, 7) > 1 Then
- n = n + 1
- crr(n, 1) = brr(i, 1): crr(n, 2) = brr(i, 2): crr(n, 3) = brr(i, 3): crr(n, 4) = brr(i, 4): crr(n, 5) = brr(i, 5): crr(n, 6) = brr(i, 6): crr(n, 7) = brr(i, 7)
- End If
- Next
- [H3].Resize(UBound(crr, 1), UBound(crr, 2)) = crr
- End Sub
复制代码 |