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 時間: 2013-9-3 10:59
