'汇总了后面几个小表,第一个按月汇总表未处理,方法同小表自己修改一下,,,
Option Explicit
Sub test()
Dim arr, i, j, k, m, pos1, pos2, sum, total
pos1 = Array(3, 4, 5, 6, 8)
pos2 = Array(0, 0, 9, 11, 15, 16, 17)
arr = Sheets("原登记表").[a1].CurrentRegion.Offset(2)
ReDim brr(1 To UBound(arr, 1), 1 To 6), sum(2 To UBound(brr, 2))
With Sheets("汇总表").[j3]
.Resize(UBound(brr, 1), (UBound(brr, 2) + 1) * (UBound(pos1) + 2)).ClearContents
For i = 0 To UBound(pos1)
m = 0: total = sum
Call qsort(arr, 1, UBound(arr, 1) - 2, 1, UBound(arr, 2), pos1(i))
For j = 1 To UBound(arr, 1) - 2
For k = 2 To UBound(brr, 2): sum(k) = sum(k) + arr(j, pos2(k)): Next
If arr(j, pos1(i)) <> arr(j + 1, pos1(i)) Then
m = m + 1: brr(m, 1) = arr(j, pos1(i))
For k = 2 To UBound(brr, 2)
brr(m, k) = sum(k)
total(k) = total(k) + sum(k)
Next
ReDim sum(2 To UBound(brr, 2))
End If
Next
m = m + 1: brr(m, 1) = "总计"
For j = 2 To UBound(brr, 2): brr(m, j) = total(j): Next
.Offset(, i * UBound(brr, 2) + i).Resize(m, UBound(brr, 2)) = brr
Next
End With
End Sub
Function qsort(arr, first, last, left, right, key)
Dim i As Long, j As Long, k As Long, x, t
i = first: j = last: x = arr((first + last) / 2, key)
While i <= j
While arr(i, key) < x: i = i + 1: Wend
While x < arr(j, key): j = j - 1: Wend
If i <= j Then
For k = left To right
t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
Next
i = i + 1: j = j - 1
End If
Wend
If first < j Then Call qsort(arr, first, j, left, right, key)
If i < last Then Call qsort(arr, i, last, left, right, key)
End Function |