- 帖子
- 163
- 主題
- 1
- 精華
- 0
- 積分
- 170
- 點名
- 0
- 作業系統
- Window 7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2010-9-5
- 最後登錄
- 2022-7-20
|
4#
發表於 2013-9-3 09:59
| 只看該作者
本帖最後由 Kubi 於 2013-9-3 10:01 編輯
回復 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 |
|
發表於 2013-9-2 13:16
| 
