- Sub test()
- Dim arr()
- Dim x, y, k, m
- Dim d
- Set d = CreateObject("scripting.dictionary")
- arr = Range("A1").CurrentRegion
- ReDim brr(1 To UBound(arr), 1 To 4)
- For x = 2 To UBound(arr)
- If d.Exists(arr(x, 1) & arr(x, 2)) Then
- m = d(arr(x, 1) & arr(x, 2))
- brr(m, 3) = arr(x, 3) + brr(m, 3)
- brr(m, 4) = arr(x, 4) + brr(m, 4)
- Else
- k = k + 1
- d(arr(x, 1) & arr(x, 2)) = k
- For y = 1 To 4
- brr(k, y) = arr(x, y)
- Next y
- End If
- Next x
- Range("g2").Resize(UBound(arr), 4) = brr
- End Sub
复制代码 |