vba計算符合項目的次數

eric093

抱歉，可能是我的權限還無法上傳檔案..

請教大家一下，如果下面二個欄位的資 料，要如何以vba計算每個人的資料中的各顏色出現幾次？

人名        顏色
小王        黃色
小花        紅色
小白        黑色
小陳        黃色
小花        白色
小陳        黃色
小王        紅色
小花        黃色
小白        藍色
小陳        白色
小白        黑色
小陳        灰色
小陳        黑色
小花        黃色
小陳        藍色
小王        白色
小花        紅色
小白        黑色
小陳        黃色
小王        白色

-----------------------------------------------

人名        白色        灰色        黃色        黑色        藍色
小王                                       
小白                                       
小花                                       
小陳

stillfish00

回復 1# eric093
使用樞紐分析表，就能簡單完成了。

oobird

上傳檔案必須壓縮後方可上傳，與會員級別無關。

Kubi

回復 1# eric093

資料在Sheet1，結果在Sheet2。
顏色排列順次無法達到版大要求。

Option Base 1

Sub test()
    Dim arr()
    Dim r As Object, c As Object
    Set r = CreateObject("Scripting.Dictionary")
    Set c = CreateObject("Scripting.Dictionary")
    r1 = 1: c1 = 1
    With Sheets("Sheet1")
        For v = 2 To .[A65536].End(3).Row
            mn = .Cells(v, 1).Value: mc = .Cells(v, 2).Value
            If Not r.exists(mn) Then r(mn) = r1: r1 = r1 + 1
            If Not c.exists(mc) Then c(mc) = c1: c1 = c1 + 1
        Next v
        ReDim arr(r.Count, c.Count)
        For v = 2 To .[A65536].End(3).Row
            mn = .Cells(v, 1).Value: mc = .Cells(v, 2).Value
            arr(r(mn), c(mc)) = arr(r(mn), c(mc)) + 1
        Next v
    End With
    With Sheets("Sheet2")
        .Cells.ClearContents
        rr = 1
        For Each x In r
            rr = rr + 1: .Cells(rr, 1).Value = x
        Next x
        cc = 1
        For Each x In c
            cc = cc + 1: .Cells(1, cc).Value = x
        Next x
        .[B2].Resize(r.Count, c.Count) = arr
        .Select
    End With
End Sub
檔案下載：http://ge.tt/888urwq

Hsieh

回復 1# eric093


   

下載 (113.78 KB)

2013-9-3 10:59

eric093

回復 4# Kubi


    感謝版大們！成功了！
    有點難，有些看不懂，我會再想辦法了解它的！
     叩'''