VBA字典按关键字提取数据

Sub test()
Dim arr, brr(1 To 3), crr
Dim qbs, i, j, k
Dim str1 As String
Dim dic As Object
Set dic = CreateObject("Scripting.dictionary")
str1 = Range("A30").Value
qbs = Range("A20").Row
arr = Range("A20").CurrentRegion
For i = 2 To UBound(arr)
    For j = 1 To UBound(brr)
        brr(j) = arr(i, j + 1)
    Next j
    dic.Add arr(i, 1), brr
Next i
crr = Filter(dic.keys, str1, True)
Range("A31").Resize(UBound(crr) + 1) = Application.WorksheetFunction.Transpose(crr)
For k = 31 To UBound(crr) + 31
    Range("B" & k).Resize(1, 3) = dic(Range("A" & k).Value)
Next k

End Sub