- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim ws As Worksheet
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- For Each ws In Worksheets
- If ws.Name <> "Sheet1" Then
- With ws
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- c = .Cells(1, .Columns.Count).End(xlToLeft).Column
- arr = .Range("a1").Resize(r, c)
- For i = 2 To UBound(arr)
- If Not d.exists(arr(i, 2)) Then
- ReDim brr(1 To 4)
- brr(1) = arr(i, 2)
- Set brr(4) = CreateObject("scripting.dictionary")
- Else
- brr = d(arr(i, 2))
- End If
- brr(2) = brr(2) + arr(i, 3)
- brr(3) = brr(3) + arr(i, 4)
- For j = 6 To UBound(arr, 2)
- brr(4)(arr(1, j)) = brr(4)(arr(1, j)) + arr(i, j)
- Next
- d(arr(i, 2)) = brr
- Next
- End With
- End If
- Next
- ReDim crr(1 To d.Count, 1 To 9)
- m = 0
- For Each aa In d.keys
- brr = d(aa)
- m = m + 1
- crr(m, 1) = brr(1)
- crr(m, 2) = brr(2)
- crr(m, 3) = brr(3)
- ReDim drr(1 To brr(4).Count, 1 To 2)
- n = 0
- For Each bb In brr(4).keys
- n = n + 1
- drr(n, 1) = bb
- drr(n, 2) = brr(4)(bb)
- Next
- For x = 1 To UBound(drr) - 1
- p = x
- For y = x + 1 To UBound(drr)
- If drr(p, 2) < drr(y, 2) Then
- p = y
- End If
- Next
- If p <> x Then
- For Z = 1 To UBound(drr, 2)
- temp = drr(x, Z)
- drr(x, Z) = drr(p, Z)
- drr(p, Z) = temp
- Next
- End If
- Next
- n = 4
- For i = 1 To Application.Min(3, UBound(drr))
- crr(m, n) = drr(i, 1)
- If Len(crr(m, 2)) <> 0 And crr(m, 2) <> 0 Then
- crr(m, n + 1) = Round(drr(i, 2) / crr(m, 2), 4)
- End If
- n = n + 2
- Next
- Next
- With Worksheets("sheet1")
- .UsedRange.Offset(1, 0).Clear
- .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
- End With
-
- End Sub
复制代码 |