samwang

¦^´_ 1# Andy2483


Sub test()
Dim Arr, Brr(1 To 10000, 1 To 100), xD, R&, C%, Sh
Dim xR As Range, x%, y$, x1%, j%, crl, T
T = Timer
Set xD = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("¾Þ§@ªí")
R = Sh.UsedRange.EntireRow.Rows.Count
C = Sh.UsedRange.EntireColumn.Columns.Count
Set Arr = Range(Sh.[a1], Sh.Cells(R, C))
For Each xR In Arr
    If IsNumeric(xR.Value) = False Or xR.Value = "" Then GoTo 888
    crl = xR.Interior.Color
    y = 2
    If xD.Exists(crl) Then
        y = xD(crl): x1 = xD(crl & "_C")
        Brr(2, x1) = Brr(2, x1) + xR.Value
        Brr(y + 1, x1) = xR.Value
        xD(crl) = y + 1
    Else
        x = x + 1: Brr(1, x) = crl: Brr(2, x) = xR.Value
        y = y + 1: Brr(y, x) = xR.Value
        xD(crl) = y: xD(crl & "_C") = x
    End If
888: Next
Workbooks.Add
[a1] = "ÃC¦â¡÷": [A2] = "¼Æ¦r¥[Á`¡÷": [A3] = "¡õ¥H¤U¬O©ú²Ó"
[b1].Resize(1000, x) = Brr
For j = 1 To x: Cells(1, j + 1).Interior.Color = Brr(1, j): Next
Range(Cells(1, 2), Cells(1, x + 1)) = ""
Cells.Columns.AutoFit
Cells.Borders.LineStyle = 1
MsgBox Timer - T & " ’"
End Sub