Kubi

¦^´_ 1# eric093

¸ê®Æ¦bSheet1¡Aµ²ªG¦bSheet2¡C
ÃC¦â±Æ¦C¶¶¦¸µLªk¹F¨ìª©¤j­n¨D¡C

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
ÀɮפU¸ü¡Ghttp://ge.tt/888urwq