- Option Explicit
- Sub test()
- Dim arr, crr, i, j, k, m, p, sht, cnt, sum
- ReDim brr(1 To 10 ^ 3, 1 To 9)
- crr = brr
- For Each sht In Sheets
- If sht.Name <> "汇总" Then
- With sht
- arr = .[a1].CurrentRegion.Resize(, 9)
- End With
- For i = 2 To UBound(arr, 1)
- m = m + 1
- For j = 1 To UBound(arr, 2) - 1
- brr(m, j) = arr(i, j)
- Next
- brr(m, j) = arr(i, 3) & arr(i, 4) & arr(i, 5)
- Next
- End If
- Next
- Call bsort(brr, 1, m, 1, UBound(brr, 2), 9)
- For i = 1 To m
- sum = sum + brr(i, 8)
- If brr(i, 9) <> brr(i + 1, 9) Then
- If i - p > 1 Then Call bsort(brr, p + 1, i, 1, UBound(brr, 2), 1)
- cnt = cnt + 1
- For j = 1 To UBound(brr, 2) - 2
- brr(cnt, j) = brr(p + 1, j)
- Next
- brr(cnt, j) = sum: sum = 0: p = i
- End If
- Next
- With Sheets("汇总").[a2]
- .Resize(Rows.Count - 1, UBound(brr, 2) - 1).ClearContents
- .Resize(cnt, UBound(brr, 2) - 1) = brr
- End With
- End Sub
- Function bsort(arr, first, last, left, right, key)
- Dim i, j, k, t
- For i = first To last - 1
- For j = first To last + first - 1 - i
- If arr(j, key) < arr(j + 1, key) Then
- For k = left To right
- t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
- Next
- End If
- Next
- Next
- End Function
复制代码
|