VBA一维转二维

阿煮

一维转二维。我用了3个字典。字典1的关键词是No，字典2的关键词是Fruit。字典3的关键词是No|Fruit，字段的值就是该No|Fruit有几条。
然后创建一个二维数组aRes，行数=字典1有几条键值；列数=字典2有几条键值。
纵向外循环遍历字典1所有键值。横向内循环遍历字典2所有键值,No|Fruit就是一个key,d3(No|Fruit)就是对应的值，即No|Fruit的数据有几条,放在aRes。
但是数量少还好。多了 比如20万行就很卡了。请问有快点的其他的思路吗。谢谢。

清风竹-

用了2个字典，请测试。
Sub 一维转二维()
    Dim t As Date
    t = Timer
    Dim lastRow As Long, i&, j&
    Dim ar(), n1, n2
    Dim d1 As Object
    Dim d2 As Object
     With ActiveSheet
          lastRow = .Cells(.Rows.Count, "A").End(3).Row
          ar = .Range("A1:B" & lastRow).Value
    End With
     ReDim brr(1 To 1000, 1 To 1000) '根据需要，定义一个足够大的数组。
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
      n1 = 1: n2 = 1
    For i = 2 To UBound(ar)
            If Not d1.Exists(ar(i, 1)) Then
                n1 = n1 + 1
                d1(ar(i, 1)) = n1
                brr(n1, 1) = ar(i, 1)
            End If
            If Not d2.Exists(ar(i, 2)) Then
                 n2 = n2 + 1
                 d2(ar(i, 2)) = n2
                 brr(1, n2) = ar(i, 2)
            End If
            brr(d1(ar(i, 1)), d2(ar(i, 2))) = brr(d1(ar(i, 1)), d2(ar(i, 2))) + 1
    Next i
   
   
    With Sheet5
        .Cells.ClearContents
        .Range("a1").Resize(n1 + 1, n2 + 1) = brr
    End With
   
    MsgBox Format(Timer - t, "0.00") & "s"
   
End Sub