|
发表于 2014-8-8 20:18
|
显示全部楼层
本楼为最佳答案
Sub Macro1()
Dim arr, brr, d, i&, j%, n&
Set d = CreateObject("scripting.dictionary")
arr = Sheets("汇总表").Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr) - 1, 1 To Sheets.Count - 1)
For j = 1 To Sheets.Count
If Sheets(j).Name <> "汇总表" Then
Sheets(j).Activate
sht = Sheets(j).Name
ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
n = Range("a65536").End(xlUp).Row - 1
[f1] = Application.Sum(Range("c2").Resize(n, 1))
[d2] = "=C2/$F$1"
With Range("d2").Resize(n, 1)
.NumberFormatLocal = "0.0%"
.FillDown
.Value = .Value
End With
[a1].Resize(n + 1, 4).Sort [d2], Order1:=xlDescending, Header:=xlGuess
h = 0
For i = 2 To n
zf = Cells(i, 1) & sht
h = h + Cells(i, 4)
If h < 0.7 Then d(zf) = Cells(i, 3) Else d(zf) = Cells(i, 3): [a2].Resize(i - 1, 4).Interior.ColorIndex = 3: Exit For
Next
End If
[f1] = ""
Next
For i = 2 To UBound(arr)
For j = 3 To UBound(arr, 2)
zf = arr(i, 1) & arr(1, j)
brr(i - 1, j - 2) = d(zf)
Next
Next
Sheets("汇总表").Activate
[c2].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub
|
|