|
- Sub lqxs()
- Dim Arr, i&, c, Brr, col%, ks, js, x&, j&, aa, bb, c1, ks1, m&
- Sheet1.Activate
- c = Array(2, 3, 2, 3)
- Arr = [a1].CurrentRegion
- ReDim Brr(1 To UBound(Arr) + 1, 1 To UBound(Arr, 2) + UBound(c) + 1)
- For i = 1 To UBound(Arr)
- Brr(i, 1) = Arr(i, 1)
- Next
- For i = 0 To UBound(c)
- If i = 0 Then
- ks = 2: ks1 = 2
- Else
- ks = ks + c(i - 1): ks1 = js + i
- End If
- js = ks + c(i): aa = 0: bb = 0: m = 0
- For j = ks To js - 1
- Brr(1, ks1 + m) = Arr(1, j)
- For x = 2 To UBound(Arr)
- Brr(x, ks1 + m) = Arr(x, j)
- If j = ks Then aa = aa + Arr(x, j)
- bb = bb + Arr(x, j)
- Next
- m = m + 1
- Next
- For x = 2 To UBound(Brr) - 1
- c1 = 0
- For j = ks To js - 1
- c1 = c1 + Arr(x, j)
- Next
- Brr(x, ks1 + m) = Arr(x, ks) / c1
- Next
- Brr(1, ks1 + m) = Arr(1, ks) & "比例"
- Brr(UBound(Arr) + 1, ks1 + m - 1) = "合计"
- Brr(UBound(Arr) + 1, ks1 + m) = aa / bb
- Next
- [a20].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
- [a20].Resize(UBound(Brr), UBound(Brr, 2)).Borders.LineStyle = 1
- End Sub
复制代码 |
|